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,
monadThrow)
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 (Conduit, Sink, await,
awaitForever, leftover, yield,
($$), (=$), (=$=))
import qualified Data.Conduit.Binary as CB
import Data.Conduit.List (consume, sinkNull)
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 Filesystem (createTree)
import Filesystem.Path.CurrentOS (FilePath, directory,
encodeString, fromText, toText,
(</>))
import Prelude hiding (FilePath)
createTemplate
:: Monad m => Conduit (FilePath, m ByteString) m ByteString
createTemplate = awaitForever $ \(fp, getBS) -> do
bs <- lift getBS
case yield bs $$ CT.decode CT.utf8 =$ sinkNull of
Nothing -> do
yield "{-# START_FILE BASE64 "
yield $ encodeUtf8 $ either id id $ toText fp
yield " #-}\n"
yield $ B64.joinWith "\n" 76 $ B64.encode bs
yield "\n"
Just _ -> do
yield "{-# START_FILE "
yield $ encodeUtf8 $ either id id $ toText fp
yield " #-}\n"
yield bs
yield "\n"
unpackTemplate
:: MonadThrow m
=> (FilePath -> Sink ByteString m ())
-> (Text -> Text)
-> Sink ByteString m ()
unpackTemplate perFile fixLine =
CT.decode CT.utf8 =$ CT.lines =$ CL.map fixLine =$ start
where
start =
await >>= maybe (return ()) go
where
go t =
case getFileName t of
Nothing -> lift $ monadThrow $ InvalidInput t
Just (fp', isBinary) -> do
let src
| isBinary = binaryLoop =$= decode64
| otherwise = textLoop True
src =$ perFile (fromText fp')
start
binaryLoop = do
await >>= maybe (return ()) go
where
go t =
case getFileName t of
Just{} -> leftover t
Nothing -> do
yield $ encodeUtf8 t
binaryLoop
textLoop isFirst =
await >>= maybe (return ()) go
where
go t =
case getFileName t of
Just{} -> leftover t
Nothing -> do
unless isFirst $ yield "\n"
yield $ encodeUtf8 t
textLoop False
getFileName t =
case T.words t of
["{-#", "START_FILE", fn, "#-}"] -> Just (fn, False)
["{-#", "START_FILE", "BASE64", fn, "#-}"] -> Just (fn, True)
_ -> Nothing
type FileReceiver m = FilePath -> Sink ByteString m ()
receiveFS :: MonadResource m
=> FilePath
-> FileReceiver m
receiveFS root rel = do
liftIO $ createTree $ directory fp
CB.sinkFile $ encodeString fp
where
fp = root </> rel
receiveMem :: MonadWriter (Map FilePath L.ByteString) m
=> FileReceiver m
receiveMem fp = do
bss <- consume
lift $ tell $ Map.singleton fp $ L.fromChunks bss
data ProjectTemplateException = InvalidInput Text
| BinaryLoopNeedsOneLine
deriving (Show, Typeable)
instance Exception ProjectTemplateException
decode64 :: Monad m => Conduit ByteString m ByteString
decode64 = codeWith 4 B64.decodeLenient
codeWith :: Monad m => Int -> (ByteString -> ByteString) -> Conduit ByteString m ByteString
codeWith size f =
loop
where
loop = await >>= maybe (return ()) push
loopWith bs
| S.null bs = loop
| otherwise = await >>= maybe (yield (f bs)) (pushWith bs)
push bs = do
let (x, y) = S.splitAt (len (len `mod` size)) bs
unless (S.null x) $ yield $ f x
loopWith y
where
len = S.length bs
pushWith bs1 bs2 | S.length bs1 + S.length bs2 < size = loopWith (S.append bs1 bs2)
pushWith bs1 bs2 = assertion1 $ assertion2 $ do
yield $ f bs1'
push y
where
m = S.length bs1 `mod` size
(x, y) = S.splitAt (size m) bs2
bs1' = S.append bs1 x
assertion1 = assert $ S.length bs1 < size
assertion2 = assert $ S.length bs1' `mod` size == 0