Switch to project-template

This commit is contained in:
Michael Snoyman 2012-11-07 10:59:18 +02:00
parent a486a2f71d
commit c3c0d0eaed
3 changed files with 5 additions and 98 deletions

View File

@ -1,93 +0,0 @@
-- FIXME: Depend on the not-yet-released project-template library.
{-# LANGUAGE OverloadedStrings #-}
module MultiFile where
import Control.Monad (unless)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.Trans.Resource (runExceptionT)
import qualified Data.ByteString as S
import qualified Data.ByteString.Base64 as B64
import Data.Conduit (Conduit, MonadResource, Sink,
await, awaitForever, leftover,
yield, ($$), (=$))
import Data.Conduit.Binary (sinkFile)
import Data.Conduit.List (sinkNull)
import qualified Data.Conduit.List as CL
import qualified Data.Conduit.Text as CT
import Data.Functor.Identity (runIdentity)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Encoding (encodeUtf8)
import Filesystem (createTree)
import Filesystem.Path.CurrentOS (FilePath, directory, encode,
encodeString, fromText, (</>))
import Prelude hiding (FilePath)
unpackMultiFile
:: MonadResource m
=> FilePath -- ^ output folder
-> (Text -> Text) -- ^ fix each input line, good for variables
-> Sink S.ByteString m ()
unpackMultiFile root 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 -> error $ "Invalid input: " ++ show t
Just (fp', isBinary) -> do
let fp = root </> fromText fp'
liftIO $ createTree $ directory fp
let src
| isBinary = binaryLoop
| otherwise = textLoop
src =$ sinkFile (encodeString fp)
start
binaryLoop = do
await >>= maybe (error "binaryLoop needs 1 line") go
where
go = yield . B64.decodeLenient . encodeUtf8
textLoop =
await >>= maybe (return ()) go
where
go t =
case getFileName t of
Just{} -> leftover t
Nothing -> do
yield $ encodeUtf8 t
yield "\n"
textLoop
getFileName t =
case T.words t of
["{-#", "START_FILE", fn, "#-}"] -> Just (fn, False)
["{-#", "START_FILE", "BASE64", fn, "#-}"] -> Just (fn, True)
_ -> Nothing
createMultiFile
:: MonadIO m
=> FilePath -- ^ folder containing the files
-> Conduit FilePath m S.ByteString -- ^ FilePath is relative to containing folder
createMultiFile root = do
awaitForever handleFile
where
handleFile fp' = do
bs <- liftIO $ S.readFile $ encodeString fp
case runIdentity $ runExceptionT $ yield bs $$ CT.decode CT.utf8 =$ sinkNull of
Left{} -> do
yield "{-# START_FILE BASE64 "
yield $ encode fp'
yield " #-}\n"
yield $ B64.encode bs
yield "\n"
Right{} -> do
yield "{-# START_FILE "
yield $ encode fp'
yield " #-}\n"
yield bs
unless ("\n" `S.isSuffixOf` bs) $ yield "\n"
where
fp = root </> fp'

View File

@ -10,7 +10,7 @@ import Data.String (fromString)
import qualified Data.Text as T import qualified Data.Text as T
import qualified Data.Text.Lazy as LT import qualified Data.Text.Lazy as LT
import qualified Data.Text.Lazy.IO as TLIO import qualified Data.Text.Lazy.IO as TLIO
import MultiFile (unpackMultiFile) import Text.ProjectTemplate (unpackTemplate, receiveFS)
import System.IO import System.IO
import Text.Shakespeare.Text (renderTextUrl, textFile) import Text.Shakespeare.Text (renderTextUrl, textFile)
@ -74,8 +74,8 @@ scaffold = do
putStrLn "That's it! I'm creating your files now..." putStrLn "That's it! I'm creating your files now..."
let sink = unpackMultiFile let sink = unpackTemplate
(fromString project) (receiveFS $ fromString project)
(T.replace "PROJECTNAME" (T.pack project)) (T.replace "PROJECTNAME" (T.pack project))
runResourceT $ yield (backendBS backend) $$ sink runResourceT $ yield (backendBS backend) $$ sink

View File

@ -106,11 +106,11 @@ executable yesod
, http-reverse-proxy >= 0.1.0.4 , http-reverse-proxy >= 0.1.0.4
, network , network
, http-conduit , http-conduit
, project-template >= 0.1
ghc-options: -Wall -threaded ghc-options: -Wall -threaded
main-is: main.hs main-is: main.hs
other-modules: MultiFile other-modules: Scaffolding.Scaffolder
Scaffolding.Scaffolder
Devel Devel
Build Build
GhcBuild GhcBuild