{-# 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.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, (</>))

-- | Create a template file from a stream of file/contents combinations.
--
-- Since 0.1.0
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"

-- | 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 -> ConduitM ByteString o m ()) -- ^ receive individual files
    -> (Text -> Text) -- ^ fix each input line, good for variables
    -> 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

-- | The first argument to 'unpackTemplate', specifying how to receive a file.
--
-- Since 0.1.0
type FileReceiver m = FilePath -> ConduitM ByteString Void 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 :: 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

-- | 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 :: 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

-- | Exceptions that can be thrown.
--
-- Since 0.1.0
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