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, encode, fromText, toText)
createTemplate
:: Monad m
=> GInfConduit (FilePath, m ByteString) m ByteString
createTemplate = awaitForever $ \(fp, getBS) -> do
bs <- lift getBS
case runException $ yield bs $$ decodeUtf8 =$ sinkNull of
Left{} -> do
yield "{-# START_FILE BASE64 "
yield $ encodeUtf8 $ either id id $ toText fp
yield " #-}\n"
yield $ B64.encode bs
yield "\n"
Right{} -> 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 =
decodeUtf8 =$ lines =$ 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
| otherwise = textLoop True
src =$ perFile (fromText fp')
start
binaryLoop = do
await >>= maybe (lift $ monadThrow BinaryLoopNeedsOneLine) go
where
go = yield . B64.decodeLenient . encodeUtf8
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
writeFile 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