{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeFamilies #-}
module Text.ProjectTemplate
(
createTemplate
, unpackTemplate
, FileReceiver
, receiveMem
, receiveFS
, ProjectTemplateException (..)
) where
import Control.Exception (Exception, assert)
import Control.Monad (unless)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Resource (MonadResource, MonadThrow,
throwM)
import Control.Monad.Writer (MonadWriter, tell)
import Data.ByteString (ByteString)
import qualified Data.ByteString as S
import qualified Data.ByteString.Base64 as B64
import qualified Data.ByteString.Lazy as L
import Data.Conduit (ConduitM, await,
awaitForever, leftover, yield,
runConduit, (.|))
import qualified Data.Conduit.Binary as CB
import Data.Conduit.List (consume, sinkNull)
import Conduit (concatMapC, chunksOfCE)
import qualified Data.Conduit.List as CL
import qualified Data.Conduit.Text as CT
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Encoding (encodeUtf8)
import Data.Typeable (Typeable)
import Data.Void (Void)
import System.Directory (createDirectoryIfMissing)
import System.FilePath (takeDirectory, (</>))
createTemplate
:: Monad m => ConduitM (FilePath, m ByteString) ByteString m ()
createTemplate :: forall (m :: * -> *).
Monad m =>
ConduitM (FilePath, m ByteString) ByteString m ()
createTemplate = forall (m :: * -> *) i o r.
Monad m =>
(i -> ConduitT i o m r) -> ConduitT i o m ()
awaitForever forall a b. (a -> b) -> a -> b
$ \(FilePath
fp, m ByteString
getBS) -> do
ByteString
bs <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m ByteString
getBS
case forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield ByteString
bs forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *).
MonadThrow m =>
Codec -> ConduitT ByteString Text m ()
CT.decode Codec
CT.utf8 forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *) i o. Monad m => ConduitT i o m ()
sinkNull of
Maybe ()
Nothing -> do
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield ByteString
"{-# START_FILE BASE64 "
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield forall a b. (a -> b) -> a -> b
$ Text -> ByteString
encodeUtf8 forall a b. (a -> b) -> a -> b
$ FilePath -> Text
T.pack FilePath
fp
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield ByteString
" #-}\n"
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield (ByteString -> ByteString
B64.encode ByteString
bs) forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *) seq.
(Monad m, IsSequence seq) =>
Index seq -> ConduitT seq seq m ()
chunksOfCE Int
76 forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *) mono a.
(Monad m, MonoFoldable mono) =>
(a -> mono) -> ConduitT a (Element mono) m ()
concatMapC (\ByteString
x -> [ByteString
x, ByteString
"\n"])
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield ByteString
"\n"
Just ()
_ -> do
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield ByteString
"{-# START_FILE "
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield forall a b. (a -> b) -> a -> b
$ Text -> ByteString
encodeUtf8 forall a b. (a -> b) -> a -> b
$ FilePath -> Text
T.pack FilePath
fp
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield ByteString
" #-}\n"
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield ByteString
bs
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield ByteString
"\n"
unpackTemplate
:: MonadThrow m
=> (FilePath -> ConduitM ByteString o m ())
-> (Text -> Text)
-> ConduitM ByteString o m ()
unpackTemplate :: forall (m :: * -> *) o.
MonadThrow m =>
(FilePath -> ConduitM ByteString o m ())
-> (Text -> Text) -> ConduitM ByteString o m ()
unpackTemplate FilePath -> ConduitM ByteString o m ()
perFile Text -> Text
fixLine =
forall (m :: * -> *).
MonadThrow m =>
Codec -> ConduitT ByteString Text m ()
CT.decode Codec
CT.utf8 forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *). Monad m => ConduitT Text Text m ()
CT.lines forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *) a b. Monad m => (a -> b) -> ConduitT a b m ()
CL.map Text -> Text
fixLine forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| ConduitT Text o m ()
start
where
start :: ConduitT Text o m ()
start =
forall (m :: * -> *) i o. Monad m => ConduitT i o m (Maybe i)
await forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return ()) Text -> ConduitT Text o m ()
go
where
go :: Text -> ConduitT Text o m ()
go Text
t =
case Text -> Maybe (Text, Bool)
getFileName Text
t of
Maybe (Text, Bool)
Nothing -> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ Text -> ProjectTemplateException
InvalidInput Text
t
Just (Text
fp', Bool
isBinary) -> do
let src :: ConduitT Text ByteString m ()
src
| Bool
isBinary = ConduitT Text ByteString m ()
binaryLoop forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *).
Monad m =>
ConduitM ByteString ByteString m ()
decode64
| Bool
otherwise = forall {m :: * -> *}.
Monad m =>
Bool -> ConduitT Text ByteString m ()
textLoop Bool
True
ConduitT Text ByteString m ()
src forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| FilePath -> ConduitM ByteString o m ()
perFile (Text -> FilePath
T.unpack Text
fp')
ConduitT Text o m ()
start
binaryLoop :: ConduitT Text ByteString m ()
binaryLoop = do
forall (m :: * -> *) i o. Monad m => ConduitT i o m (Maybe i)
await forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return ()) Text -> ConduitT Text ByteString m ()
go
where
go :: Text -> ConduitT Text ByteString m ()
go Text
t =
case Text -> Maybe (Text, Bool)
getFileName Text
t of
Just{} -> forall i o (m :: * -> *). i -> ConduitT i o m ()
leftover Text
t
Maybe (Text, Bool)
Nothing -> do
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield forall a b. (a -> b) -> a -> b
$ Text -> ByteString
encodeUtf8 Text
t
ConduitT Text ByteString m ()
binaryLoop
textLoop :: Bool -> ConduitT Text ByteString m ()
textLoop Bool
isFirst =
forall (m :: * -> *) i o. Monad m => ConduitT i o m (Maybe i)
await forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return ()) Text -> ConduitT Text ByteString m ()
go
where
go :: Text -> ConduitT Text ByteString m ()
go Text
t =
case Text -> Maybe (Text, Bool)
getFileName Text
t of
Just{} -> forall i o (m :: * -> *). i -> ConduitT i o m ()
leftover Text
t
Maybe (Text, Bool)
Nothing -> do
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
isFirst forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield ByteString
"\n"
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield forall a b. (a -> b) -> a -> b
$ Text -> ByteString
encodeUtf8 Text
t
Bool -> ConduitT Text ByteString m ()
textLoop Bool
False
getFileName :: Text -> Maybe (Text, Bool)
getFileName Text
t =
case Text -> [Text]
T.words Text
t of
[Text
"{-#", Text
"START_FILE", Text
fn, Text
"#-}"] -> forall a. a -> Maybe a
Just (Text
fn, Bool
False)
[Text
"{-#", Text
"START_FILE", Text
"BASE64", Text
fn, Text
"#-}"] -> forall a. a -> Maybe a
Just (Text
fn, Bool
True)
[Text]
_ -> forall a. Maybe a
Nothing
type FileReceiver m = FilePath -> ConduitM ByteString Void m ()
receiveFS :: MonadResource m
=> FilePath
-> FileReceiver m
receiveFS :: forall (m :: * -> *). MonadResource m => FilePath -> FileReceiver m
receiveFS FilePath
root FilePath
rel = do
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
takeDirectory FilePath
fp
forall (m :: * -> *) o.
MonadResource m =>
FilePath -> ConduitT ByteString o m ()
CB.sinkFile FilePath
fp
where
fp :: FilePath
fp = FilePath
root FilePath -> FilePath -> FilePath
</> FilePath
rel
receiveMem :: MonadWriter (Map FilePath L.ByteString) m
=> FileReceiver m
receiveMem :: forall (m :: * -> *).
MonadWriter (Map FilePath ByteString) m =>
FileReceiver m
receiveMem FilePath
fp = do
[ByteString]
bss <- forall (m :: * -> *) a o. Monad m => ConduitT a o m [a]
consume
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell forall a b. (a -> b) -> a -> b
$ forall k a. k -> a -> Map k a
Map.singleton FilePath
fp forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
L.fromChunks [ByteString]
bss
data ProjectTemplateException = InvalidInput Text
| BinaryLoopNeedsOneLine
deriving (Int -> ProjectTemplateException -> FilePath -> FilePath
[ProjectTemplateException] -> FilePath -> FilePath
ProjectTemplateException -> FilePath
forall a.
(Int -> a -> FilePath -> FilePath)
-> (a -> FilePath) -> ([a] -> FilePath -> FilePath) -> Show a
showList :: [ProjectTemplateException] -> FilePath -> FilePath
$cshowList :: [ProjectTemplateException] -> FilePath -> FilePath
show :: ProjectTemplateException -> FilePath
$cshow :: ProjectTemplateException -> FilePath
showsPrec :: Int -> ProjectTemplateException -> FilePath -> FilePath
$cshowsPrec :: Int -> ProjectTemplateException -> FilePath -> FilePath
Show, Typeable)
instance Exception ProjectTemplateException
decode64 :: Monad m => ConduitM ByteString ByteString m ()
decode64 :: forall (m :: * -> *).
Monad m =>
ConduitM ByteString ByteString m ()
decode64 = forall (m :: * -> *).
Monad m =>
Int
-> (ByteString -> ByteString)
-> ConduitM ByteString ByteString m ()
codeWith Int
4 ByteString -> ByteString
B64.decodeLenient
codeWith :: Monad m => Int -> (ByteString -> ByteString) -> ConduitM ByteString ByteString m ()
codeWith :: forall (m :: * -> *).
Monad m =>
Int
-> (ByteString -> ByteString)
-> ConduitM ByteString ByteString m ()
codeWith Int
size ByteString -> ByteString
f =
ConduitT ByteString ByteString m ()
loop
where
loop :: ConduitT ByteString ByteString m ()
loop = forall (m :: * -> *) i o. Monad m => ConduitT i o m (Maybe i)
await forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return ()) ByteString -> ConduitT ByteString ByteString m ()
push
loopWith :: ByteString -> ConduitT ByteString ByteString m ()
loopWith ByteString
bs
| ByteString -> Bool
S.null ByteString
bs = ConduitT ByteString ByteString m ()
loop
| Bool
otherwise = forall (m :: * -> *) i o. Monad m => ConduitT i o m (Maybe i)
await forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield (ByteString -> ByteString
f ByteString
bs)) (ByteString -> ByteString -> ConduitT ByteString ByteString m ()
pushWith ByteString
bs)
push :: ByteString -> ConduitT ByteString ByteString m ()
push ByteString
bs = do
let (ByteString
x, ByteString
y) = Int -> ByteString -> (ByteString, ByteString)
S.splitAt (Int
len forall a. Num a => a -> a -> a
- (Int
len forall a. Integral a => a -> a -> a
`mod` Int
size)) ByteString
bs
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString -> Bool
S.null ByteString
x) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
f ByteString
x
ByteString -> ConduitT ByteString ByteString m ()
loopWith ByteString
y
where
len :: Int
len = ByteString -> Int
S.length ByteString
bs
pushWith :: ByteString -> ByteString -> ConduitT ByteString ByteString m ()
pushWith ByteString
bs1 ByteString
bs2 | ByteString -> Int
S.length ByteString
bs1 forall a. Num a => a -> a -> a
+ ByteString -> Int
S.length ByteString
bs2 forall a. Ord a => a -> a -> Bool
< Int
size = ByteString -> ConduitT ByteString ByteString m ()
loopWith (ByteString -> ByteString -> ByteString
S.append ByteString
bs1 ByteString
bs2)
pushWith ByteString
bs1 ByteString
bs2 = ConduitT ByteString ByteString m ()
-> ConduitT ByteString ByteString m ()
assertion1 forall a b. (a -> b) -> a -> b
$ ConduitT ByteString ByteString m ()
-> ConduitT ByteString ByteString m ()
assertion2 forall a b. (a -> b) -> a -> b
$ do
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
f ByteString
bs1'
ByteString -> ConduitT ByteString ByteString m ()
push ByteString
y
where
m :: Int
m = ByteString -> Int
S.length ByteString
bs1 forall a. Integral a => a -> a -> a
`mod` Int
size
(ByteString
x, ByteString
y) = Int -> ByteString -> (ByteString, ByteString)
S.splitAt (Int
size forall a. Num a => a -> a -> a
- Int
m) ByteString
bs2
bs1' :: ByteString
bs1' = ByteString -> ByteString -> ByteString
S.append ByteString
bs1 ByteString
x
assertion1 :: ConduitT ByteString ByteString m ()
-> ConduitT ByteString ByteString m ()
assertion1 = forall a. (?callStack::CallStack) => Bool -> a -> a
assert forall a b. (a -> b) -> a -> b
$ ByteString -> Int
S.length ByteString
bs1 forall a. Ord a => a -> a -> Bool
< Int
size
assertion2 :: ConduitT ByteString ByteString m ()
-> ConduitT ByteString ByteString m ()
assertion2 = forall a. (?callStack::CallStack) => Bool -> a -> a
assert forall a b. (a -> b) -> a -> b
$ ByteString -> Int
S.length ByteString
bs1' forall a. Integral a => a -> a -> a
`mod` Int
size forall a. Eq a => a -> a -> Bool
== Int
0