module Text.ProjectTemplate
(
createTemplate
, unpackTemplate
, FileReceiver
, receiveMem
, receiveFS
, ProjectTemplateException (..)
) where
import ClassyPrelude.Conduit
import Control.Monad.Writer (MonadWriter, tell)
import qualified Data.ByteString.Base64 as B64
import Data.Typeable (Typeable)
import Filesystem (createTree)
import Filesystem.Path.CurrentOS (directory, fromText, toText)
import qualified Data.Conduit.Base64
import qualified Data.Conduit.Binary as CB
import qualified Data.Conduit.Text as CT
import qualified Data.Conduit.List as CL
createTemplate
:: Monad m
=> GInfConduit (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 =$= Data.Conduit.Base64.decode
| 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 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 $ unpack fp
where
fp = root </> rel
receiveMem :: MonadWriter (Map FilePath LByteString) m
=> FileReceiver m
receiveMem fp = do
bss <- consume
lift $ tell $ singleton fp $ fromChunks bss
data ProjectTemplateException = InvalidInput Text
| BinaryLoopNeedsOneLine
deriving (Show, Typeable)
instance Exception ProjectTemplateException