{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeFamilies #-}
module Text.ProjectTemplate
( -- * Create a template
createTemplate
-- * Unpack a template
, unpackTemplate
-- ** Receivers
, FileReceiver
, receiveMem
, receiveFS
-- * Exceptions
, 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.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, MonadResource, MonadThrow,
Sink, await, awaitForever, leftover,
monadThrow, 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)
-- | Create a template file from a stream of file/contents combinations.
--
-- Since 0.1.0
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"
-- | Unpack a template to some destination. Destination is provided by the
-- first argument.
--
-- The second argument allows you to modify the incoming stream, usually to
-- replace variables. For example, to replace PROJECTNAME with myproject, you
-- could use:
--
-- > Data.Text.replace "PROJECTNAME" "myproject"
--
-- Note that this will affect both file contents and file names.
--
-- Since 0.1.0
unpackTemplate
:: MonadThrow m
=> (FilePath -> Sink ByteString m ()) -- ^ receive individual files
-> (Text -> Text) -- ^ fix each input line, good for variables
-> 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
-- | The first argument to 'unpackTemplate', specifying how to receive a file.
--
-- Since 0.1.0
type FileReceiver m = FilePath -> Sink ByteString m ()
-- | Receive files to the given folder on the filesystem.
--
-- > unpackTemplate (receiveFS "some-destination") (T.replace "PROJECTNAME" "foo")
--
-- Since 0.1.0
receiveFS :: MonadResource m
=> FilePath -- ^ root
-> FileReceiver m
receiveFS root rel = do
liftIO $ createTree $ directory fp
CB.sinkFile $ encodeString fp
where
fp = root </> rel
-- | Receive files to a @Writer@ monad in memory.
--
-- > execWriter $ runExceptionT_ $ src $$ unpackTemplate receiveMem id
--
-- Since 0.1.0
receiveMem :: MonadWriter (Map FilePath L.ByteString) m
=> FileReceiver m
receiveMem fp = do
bss <- consume
lift $ tell $ Map.singleton fp $ L.fromChunks bss
-- | Exceptions that can be thrown.
--
-- Since 0.1.0
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