diff --git a/mole.cabal b/mole.cabal
--- a/mole.cabal
+++ b/mole.cabal
@@ -1,99 +1,86 @@
-name: mole
-version: 0.0.3
-
-synopsis: A glorified string replacement tool
+name: mole
+version: 0.0.5
+cabal-version: >=1.10
+build-type: Simple
+license: MIT
+license-file: LICENSE
+maintainer: tomas.carnecky@gmail.com
+synopsis: A glorified string replacement tool
description:
A glorified string replacement tool. For a very specific purpose. That
purpose being to compile and optimize a static website (or a single-page
application). Mole inspects source, builds a complete dependency tree,
minifies and compresses the files, adds fingerprints and writes the result
to a directory.
-
-license: MIT
-license-file: LICENSE
-author: Tomas Carnecky
-maintainer: tomas.carnecky@gmail.com
-
-category: System
-
-build-type: Simple
-cabal-version: >=1.10
-
+category: System
+author: Tomas Carnecky
source-repository head
- type: git
+ type: git
location: git://github.com/wereHamster/mole.git
-
executable mole
- hs-source-dirs: src
- default-language: Haskell2010
-
- ghc-options: -Wall -threaded -rtsopts
-
- main-is: Main.hs
-
- other-modules:
- Main
- , Data.Mole.Builder.Internal.Fingerprint
- , Data.Mole.Builder.Internal.Template
- , Data.Mole.Builder.Binary
- , Data.Mole.Builder.External
- , Data.Mole.Builder.Html
- , Data.Mole.Builder.Image
- , Data.Mole.Builder.JavaScript
- , Data.Mole.Builder.Stylesheet
- , Data.Mole.Builder
- , Data.Mole.Core
- , Data.Mole.Server
- , Data.Mole.Types
- , Data.Mole.Watcher
-
+ main-is: Main.hs
build-depends:
- base >=4.6 && <4.9
- , containers
- , bytestring
- , base64-bytestring
- , tagsoup
- , stm
- , cryptohash
- , filepath
- , filemanip
- , fsnotify >=0.2
- , directory
- , snap
- , snap-server
- , text
- , transformers
- , process
- , attoparsec
- , network-uri
- , optparse-applicative
- , time
- , mtl
- , kraken
- , unix
- , css-syntax
-
+ base >=4.6 && <4.10,
+ containers >=0.5.7.1 && <0.6,
+ bytestring >=0.10.8.1 && <0.11,
+ base64-bytestring >=1.0.0.1 && <1.1,
+ tagsoup ==0.14.*,
+ stm >=2.4.4.1 && <2.5,
+ cryptohash >=0.11.9 && <0.12,
+ filepath >=1.4.1.0 && <1.5,
+ filemanip >=0.3.6.3 && <0.4,
+ fsnotify ==0.2.*,
+ directory >=1.2.6.2 && <1.3,
+ snap >=1.0.0.1 && <1.1,
+ snap-server >=1.0.1.0 && <1.1,
+ text >=1.2.2.1 && <1.3,
+ transformers >=0.5.2.0 && <0.6,
+ process >=1.4.2.0 && <1.5,
+ attoparsec >=0.13.1.0 && <0.14,
+ network-uri >=2.6.1.0 && <2.7,
+ optparse-applicative >=0.12.1.0 && <0.13,
+ time >=1.6.0.1 && <1.7,
+ mtl >=2.2.1 && <2.3,
+ kraken >=0.0.3 && <0.1,
+ unix >=2.7.2.0 && <2.8,
+ css-syntax >=0.0.5 && <0.1
+ default-language: Haskell2010
+ hs-source-dirs: src
+ other-modules:
+ Main
+ Data.Mole.Builder.Internal.Fingerprint
+ Data.Mole.Builder.Internal.Template
+ Data.Mole.Builder.Binary
+ Data.Mole.Builder.External
+ Data.Mole.Builder.Html
+ Data.Mole.Builder.Image
+ Data.Mole.Builder.JavaScript
+ Data.Mole.Builder.Stylesheet
+ Data.Mole.Builder
+ Data.Mole.Core
+ Data.Mole.Server
+ Data.Mole.Types
+ Data.Mole.Watcher
+ ghc-options: -Wall -threaded -rtsopts
test-suite spec
- hs-source-dirs: src test
- default-language: Haskell2010
-
- main-is: Test.hs
- type: exitcode-stdio-1.0
-
+ type: exitcode-stdio-1.0
+ main-is: Test.hs
build-depends:
- base <4.9
- , hspec
- , smallcheck
- , hspec-smallcheck
- , vector
- , text
- , unordered-containers
- , time
- , kraken
- , attoparsec
- , stm
- , bytestring
- , containers
+ base >=4.6 && <4.10,
+ hspec >=2.2.3 && <2.3,
+ smallcheck >=1.1.1 && <1.2,
+ hspec-smallcheck >=0.4.1 && <0.5,
+ vector >=0.11.0.0 && <0.12,
+ text >=1.2.2.1 && <1.3,
+ unordered-containers >=0.2.7.1 && <0.3,
+ time >=1.6.0.1 && <1.7,
+ kraken >=0.0.3 && <0.1,
+ attoparsec >=0.13.1.0 && <0.14,
+ stm >=2.4.4.1 && <2.5,
+ bytestring >=0.10.8.1 && <0.11,
+ containers >=0.5.7.1 && <0.6
+ default-language: Haskell2010
+ hs-source-dirs: src test
diff --git a/src/Data/Mole/Builder.hs b/src/Data/Mole/Builder.hs
--- a/src/Data/Mole/Builder.hs
+++ b/src/Data/Mole/Builder.hs
@@ -14,7 +14,7 @@
builderForFile :: FilePath -> String -> Handle -> AssetId -> IO Builder
builderForFile basePath x = case takeExtension x of
- ".css" -> stylesheetBuilder x x
+ ".css" -> stylesheetBuilder x
".html" -> htmlBuilder (drop (length basePath) x) x
".js" -> javascriptBuilder x
".png" -> imageBuilder x "image/png"
diff --git a/src/Data/Mole/Builder/Binary.hs b/src/Data/Mole/Builder/Binary.hs
--- a/src/Data/Mole/Builder/Binary.hs
+++ b/src/Data/Mole/Builder/Binary.hs
@@ -16,7 +16,8 @@
return $ Builder
{ assetSources = S.singleton src
, assetDependencies = S.empty
- , packageAsset = const $ Right $ Result (fingerprint body src) $ Just (body, contentType)
+ , packageAsset = const $ Right $ Result (PublicIdentifier $ fingerprint body src) $ Just (body, contentType)
+ , sourceFingerprint = body
}
@@ -28,4 +29,5 @@
{ assetSources = S.singleton src
, assetDependencies = S.empty
, packageAsset = const $ Right $ Result pubId (Just (body, contentType))
+ , sourceFingerprint = body
}
diff --git a/src/Data/Mole/Builder/External.hs b/src/Data/Mole/Builder/External.hs
--- a/src/Data/Mole/Builder/External.hs
+++ b/src/Data/Mole/Builder/External.hs
@@ -2,15 +2,26 @@
import qualified Data.Set as S
+import qualified Data.Text.Encoding as T
import Data.Mole.Types
+-- | The external builder is used to replace 'AssetId's with a constant.
+--
+-- One use case is if you want to insert a version number or git revision
+-- in a HTML or JavaScript file:
+--
+--
+--
+-- and then add @--asset VERSION=`git rev-parse HEAD`@ to the command line.
+
externalBuilder :: PublicIdentifier -> Handle -> AssetId -> IO Builder
externalBuilder pubId _ _ = do
return $ Builder
{ assetSources = S.empty
, assetDependencies = S.empty
, packageAsset = const $ Right $ Result pubId Nothing
+ , sourceFingerprint = T.encodeUtf8 $ unPublicIdentifier pubId
}
diff --git a/src/Data/Mole/Builder/Html.hs b/src/Data/Mole/Builder/Html.hs
--- a/src/Data/Mole/Builder/Html.hs
+++ b/src/Data/Mole/Builder/Html.hs
@@ -1,16 +1,21 @@
+{-# LANGUAGE OverloadedStrings #-}
+
module Data.Mole.Builder.Html
( htmlBuilder
) where
import Control.Monad
+import Control.Applicative
import Data.Map (Map)
import qualified Data.Map as M
import qualified Data.Set as S
+import Data.Text (Text)
import qualified Data.Text as T
+import qualified Data.Text.IO as T
import qualified Data.Text.Encoding as T
import Data.Maybe
@@ -24,41 +29,47 @@
data Transformer = Transformer
- { tagSelector :: String -> Bool
- , attributeName :: String
- , depExtractor :: String -> [AssetId]
- , attributeRenderer :: Map AssetId String -> String -> Either Error String
+ { tagSelector :: Text -> Bool
+ -- ^ Predicate which must return true for the tag to be processed.
+
+ , attributeName :: Text
+ -- ^ Attribute name whose value is processed.
+
+ , depExtractor :: Text -> [AssetId]
+ -- ^ Function which extracts dependencies from the attribute value.
+
+ , attributeRenderer :: Map AssetId PublicIdentifier -> Text -> Either Error Text
+ -- ^ Once the dependencies have been resolved, this function is used to
+ -- build the new attribute value.
}
-extractSingleAsset :: String -> [AssetId]
+extractSingleAsset :: Text -> [AssetId]
extractSingleAsset x = [AssetId x]
-renderSingleAttribute :: Map AssetId String -> String -> Either Error String
+renderSingleAttribute :: Map AssetId PublicIdentifier -> Text -> Either Error Text
renderSingleAttribute m v =
- case M.lookup (AssetId v) m of
- Just v' -> Right v'
- Nothing -> case M.lookup (AssetId $ tail v) m of
- Just v'' -> Right v''
- Nothing -> Left (UndeclaredDependency (AssetId v))
+ case M.lookup (AssetId v) m <|> M.lookup (AssetId $ T.tail v) m of
+ Just (PublicIdentifier x) -> Right x
+ Nothing -> Left (UndeclaredDependency (AssetId v))
-extractStylesheetAssets :: String -> [AssetId]
+extractStylesheetAssets :: Text -> [AssetId]
extractStylesheetAssets v =
- let Right tokens = tokenize (T.pack v)
+ let Right tokens = tokenize v
in catMaybes $ (flip map) tokens $ \t ->
case t of
- (Url x) -> Just $ urlAssetId (T.unpack x)
+ (Url x) -> Just $ urlAssetId x
_ -> Nothing
-renderStylesheetAssets :: Map AssetId String -> String -> Either Error String
+renderStylesheetAssets :: Map AssetId PublicIdentifier -> Text -> Either Error Text
renderStylesheetAssets m v = do
- let Right tokens = tokenize (T.pack v)
+ let Right tokens = tokenize v
newTokens <- forM tokens $ \t -> case t of
- (Url x) -> case M.lookup (urlAssetId (T.unpack x)) m of
- Nothing -> Left (UndeclaredDependency (AssetId (T.unpack x)))
- Just v -> Right (Url $ T.pack $ reconstructUrl (T.unpack x) v)
+ (Url x) -> case M.lookup (urlAssetId x) m of
+ Nothing -> Left (UndeclaredDependency (AssetId x))
+ Just (PublicIdentifier pubId) -> Right (Url $ reconstructUrl x pubId)
_ -> return t
- return $ T.unpack $ serialize newTokens
+ return $ serialize newTokens
tagTransformers :: [Transformer]
tagTransformers =
@@ -70,18 +81,21 @@
, Transformer (const True) "style" extractStylesheetAssets renderStylesheetAssets
]
-tagTransformersFor :: String -> [Transformer]
+-- | A tag may be associated with multiple transformers. That situation arises
+-- when we want to process multiple attributes of a particular tag.
+tagTransformersFor :: Text -> [Transformer]
tagTransformersFor tag = filter (\t -> tagSelector t tag) tagTransformers
-toInlineStyleDep :: [AssetId] -> [Tag String] -> [AssetId]
+toInlineStyleDep :: [AssetId] -> [Tag Text] -> [AssetId]
toInlineStyleDep acc [] = acc
toInlineStyleDep acc ((TagOpen "style" _):(TagText text):(TagClose "style"):xs)
= toInlineStyleDep (acc ++ extractStylesheetAssets text) xs
-toInlineStyleDep acc (x:xs) = toInlineStyleDep acc xs
+toInlineStyleDep acc (_:xs) = toInlineStyleDep acc xs
-renderInlineStyles :: Map AssetId String -> [Tag String] -> Either Error [Tag String]
-renderInlineStyles m [] = return []
+
+renderInlineStyles :: Map AssetId PublicIdentifier -> [Tag Text] -> Either Error [Tag Text]
+renderInlineStyles _ [] = return []
renderInlineStyles m ((TagOpen "style" attrs):(TagText text):(TagClose "style"):xs) = do
text' <- renderStylesheetAssets m text
rest <- renderInlineStyles m xs
@@ -90,43 +104,45 @@
xs' <- renderInlineStyles m xs
return $ x:xs'
-htmlBuilder :: String -> String -> Handle -> AssetId -> IO Builder
-htmlBuilder pubId src _ _ = do
- body <- readFile src
- let tags = parseTags body
- let deps = concatMap toDep tags
- let inlineStyleDeps = toInlineStyleDep [] tags
- return $ Builder (S.singleton src) (S.fromList (deps ++ inlineStyleDeps)) (render tags)
- where
- toDep :: Tag String -> [AssetId]
- toDep (TagOpen tag attrs) =
- concatMap (\t -> case lookup (attributeName t) attrs of
- Nothing -> []
- Just v -> depExtractor t v
- ) (tagTransformersFor tag)
- toDep _ = []
+tagDependencies :: Tag Text -> [AssetId]
+tagDependencies (TagOpen tag attrs) =
+ mconcat $ catMaybes $ map (\t -> depExtractor t <$> lookup (attributeName t) attrs)
+ (tagTransformersFor tag)
+tagDependencies _ = []
- render :: [Tag String] -> Map AssetId String -> Either Error Result
- render tags m = do
- t' <- forM tags $ \t -> do
- insertResult m t
- t'' <- renderInlineStyles m t'
+insertResult :: Map AssetId PublicIdentifier -> Tag Text -> Either Error (Tag Text)
+insertResult m (TagOpen tag attrs) = TagOpen
+ <$> pure tag
+ <*> foldM (\a tf -> mapM (overrideAttr tf m) a) attrs (tagTransformersFor tag)
+insertResult _ t = pure t
- let body = T.encodeUtf8 $ T.pack $ renderTags t''
- return $ Result pubId $ Just (body, "text/html")
- insertResult :: Map AssetId String -> Tag String -> Either Error (Tag String)
- insertResult m t@(TagOpen tag attrs) = do
- let tfs = tagTransformersFor tag
- let f at tf = mapM (overrideAttr tf m) at
+overrideAttr :: Transformer -> Map AssetId PublicIdentifier -> (Text,Text) -> Either Error (Text,Text)
+overrideAttr tf m (k,v)
+ | k == attributeName tf = attributeRenderer tf m v >>= \v' -> Right (k, v')
+ | otherwise = Right (k,v)
- TagOpen <$> (pure tag) <*> foldM f attrs tfs
- insertResult _ t = pure t
+htmlBuilder :: String -> String -> Handle -> AssetId -> IO Builder
+htmlBuilder pubId src _ _ = do
+ body <- T.readFile src
- overrideAttr :: Transformer -> Map AssetId String -> (String,String) -> Either Error (String,String)
- overrideAttr tf m (k,v)
- | k == attributeName tf = attributeRenderer tf m v >>= \v' -> Right (k, v')
- | otherwise = Right (k,v)
+ let tags = parseTags body
+ let deps = concatMap tagDependencies tags
+ let inlineStyleDeps = toInlineStyleDep [] tags
+
+ return $ Builder
+ { assetSources = S.singleton src
+ , assetDependencies = S.fromList (deps ++ inlineStyleDeps)
+ , packageAsset = render tags
+ , sourceFingerprint = T.encodeUtf8 body
+ }
+
+ where
+ render :: [Tag Text] -> Map AssetId PublicIdentifier -> Either Error Result
+ render tags m = do
+ body <- T.encodeUtf8 . renderTags <$>
+ (forM tags (insertResult m) >>= renderInlineStyles m)
+ return $ Result (PublicIdentifier $ T.pack pubId) $ Just (body, "text/html")
diff --git a/src/Data/Mole/Builder/Image.hs b/src/Data/Mole/Builder/Image.hs
--- a/src/Data/Mole/Builder/Image.hs
+++ b/src/Data/Mole/Builder/Image.hs
@@ -5,6 +5,7 @@
import qualified Data.Set as S
import qualified Data.ByteString as BS
+import qualified Data.Text as T
import Data.Maybe
import Data.Time
import Text.Printf
@@ -25,7 +26,7 @@
originalBody <- BS.readFile src
let fp = contentHash originalBody
cacheDir <- lookupEnv "XDG_CACHE_DIR"
- let cacheName = (fromMaybe ".cache" cacheDir) "kraken" fp
+ let cacheName = (fromMaybe ".cache" cacheDir) "kraken" T.unpack fp
inCache <- fileExist cacheName
body <- if inCache
then do BS.readFile cacheName
@@ -66,7 +67,8 @@
return $ Builder
{ assetSources = S.singleton src
, assetDependencies = S.empty
- , packageAsset = const $ Right $ Result (fingerprint body src) $ Just (body, contentType)
+ , packageAsset = const $ Right $ Result (PublicIdentifier $ fingerprint body src) $ Just (body, contentType)
+ , sourceFingerprint = originalBody
}
diff --git a/src/Data/Mole/Builder/Internal/Fingerprint.hs b/src/Data/Mole/Builder/Internal/Fingerprint.hs
--- a/src/Data/Mole/Builder/Internal/Fingerprint.hs
+++ b/src/Data/Mole/Builder/Internal/Fingerprint.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE OverloadedStrings #-}
+
module Data.Mole.Builder.Internal.Fingerprint
( contentHash
, fingerprint
@@ -6,8 +8,10 @@
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
-import Data.ByteString.Char8 (unpack)
import Data.Word
+import Data.Text (Text)
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as T
import Crypto.Hash.SHA3
@@ -15,8 +19,8 @@
-contentHash :: ByteString -> String
-contentHash body = unpack $ BS.map (\x -> alnum $ rem x 62) $ hash 512 body
+contentHash :: ByteString -> Text
+contentHash body = T.decodeUtf8 $ BS.map (\x -> alnum $ rem x 62) $ hash 512 body
where
alnum :: Word8 -> Word8
alnum x
@@ -26,14 +30,14 @@
| otherwise = error $ "Out of range: " ++ show x
-fingerprint :: ByteString -> String -> String
+fingerprint :: ByteString -> String -> Text
fingerprint body name = mconcat
- [ take prefixLength h
+ [ T.take prefixLength h
, "-"
- , takeBaseName name
+ , T.pack (takeBaseName name)
, "-"
- , drop prefixLength h
- , takeExtension name
+ , T.drop prefixLength h
+ , T.pack (takeExtension name)
]
where
h = contentHash body
diff --git a/src/Data/Mole/Builder/Internal/Template.hs b/src/Data/Mole/Builder/Internal/Template.hs
--- a/src/Data/Mole/Builder/Internal/Template.hs
+++ b/src/Data/Mole/Builder/Internal/Template.hs
@@ -10,44 +10,69 @@
import qualified Data.Attoparsec.Text as AP
+import Data.Maybe
import Data.Monoid
import Data.Mole.Types
-type Context = Text -> Either Error Text
-data Fragment = Lit Text | Var Text deriving (Show, Eq)
+type Bracket = (Text,Text)
+type Brackets = [Bracket]
+type Context = Bracket -> Text -> Either Error Text
+data Fragment = Lit !Text | Var !Bracket !Text deriving (Show, Eq)
newtype Template = Template [Fragment] deriving (Show, Eq)
-template :: String -> Template
-template input = case AP.parseOnly (AP.many1 fragmentParser) (T.pack input) of
- Left x -> error $ x ++ " on input '" ++ input ++ "'"
- Right x -> Template $ mergeLiterals $ concat x
+template :: Brackets -> Text -> Template
+template brackets input = case AP.parseOnly (fragmentParser brackets) input of
+ Left x -> error $ x ++ " on input '" ++ T.unpack input ++ "'"
+ Right x -> Template $ mergeLiterals x
mergeLiterals :: [Fragment] -> [Fragment]
mergeLiterals = reverse . foldl f []
where
- f [] frag = [frag]
- f ((Lit a):xs) (Lit b) = (Lit $ a <> b) : xs
- f acc frag = frag:acc
+ f acc (Lit "") = acc
+ f ((Lit a):xs) (Lit b) = (Lit $ a <> b) : xs
+ f acc frag = frag:acc
-fragmentParser :: AP.Parser [Fragment]
-fragmentParser = var <|> lit
+fragmentParser :: Brackets -> AP.Parser [Fragment]
+fragmentParser brackets = go
where
- var = do
- text <- AP.string "<*" *> AP.manyTill AP.anyChar (AP.string "*>")
- return $ [Var $ T.strip $ T.pack text]
+ go = lit <|> rest
+ -- The rest of the input as a single 'Lit'. The contents of the text may be
+ -- empty, but we drop empty literals during postprocessing.
+ rest = pure . Lit <$> AP.takeText
+
+ -- Matches 'Text' which marks the beginning of a 'Var'.
+ varMarkers = foldl1 (<|>) $ map (AP.string . fst) brackets
+
+ -- The contents of a variable and its end marker. The start marker must be
+ -- consumed before. This function recurses into 'go' to continue parsing
+ -- the rest of the input.
+ var (a,b) = do
+ text <- T.strip . T.pack <$> AP.manyTill AP.anyChar (AP.string b)
+ (Var (a, b) text :) <$> go
+
+ -- A literal (may be empty), up until the start marker of a var, followed
+ -- by a var.
lit = do
- text <- AP.takeTill ('<'==)
- ( (var <|> (AP.anyChar >>= \c -> return $ [Lit $ T.singleton c]))
- >>= \v -> return $ [Lit text] ++ v)
- <|> (if T.null text then fail "literal" else return [Lit text])
+ (text, a) <- stringTill varMarkers
+ let b = fromJust $ lookup a brackets
+ (Lit (T.pack text) :) <$> var (a, b)
-render :: Template -> Context -> Either Error String
-render (Template frags) ctxFunc = do
- res <- traverse renderFrag frags
- return $ T.unpack $ mconcat res
+ -- The string until 'end' matches. What matched at the end is returned, to
+ -- give the caller a chance to go different paths depending on how the
+ -- string ended.
+ stringTill end = scan
+ where scan = ((\x -> ([],x)) <$> end) <|> do
+ x <- AP.anyChar
+ (xs, e) <- scan
+ return $ (x:xs, e)
+
+
+render :: Template -> Context -> Either Error Text
+render (Template frags) ctxFunc =
+ mconcat <$> traverse renderFrag frags
where
renderFrag (Lit s) = pure s
- renderFrag (Var x) = ctxFunc x
+ renderFrag (Var bracket x) = ctxFunc bracket x
diff --git a/src/Data/Mole/Builder/JavaScript.hs b/src/Data/Mole/Builder/JavaScript.hs
--- a/src/Data/Mole/Builder/JavaScript.hs
+++ b/src/Data/Mole/Builder/JavaScript.hs
@@ -1,20 +1,47 @@
+{-# LANGUAGE OverloadedStrings #-}
+
module Data.Mole.Builder.JavaScript where
import qualified Data.Set as S
+import qualified Data.Map as M
+import Data.Map (Map)
-import qualified Data.ByteString as BS
+import Data.Maybe
+import Data.Monoid
+import qualified Data.Text.IO as T
+import qualified Data.Text.Encoding as T
+
import Data.Mole.Types
import Data.Mole.Builder.Internal.Fingerprint
+import Data.Mole.Builder.Internal.Template
javascriptBuilder :: String -> Handle -> AssetId -> IO Builder
javascriptBuilder src _ _ = do
- body <- BS.readFile src
+ body <- T.readFile src
+
+ let t@(Template fragments) = template [("__assetUrl(\"", "\")")] body
+ let deps = catMaybes $ (flip map) fragments $ \f -> case f of
+ (Lit _) -> Nothing
+ (Var _ x) -> Just $ AssetId x
+
return $ Builder
{ assetSources = S.singleton src
- , assetDependencies = S.empty
- , packageAsset = const $ Right $ Result (fingerprint body src) $ Just (body, "text/javascript")
+ , assetDependencies = S.fromList deps
+ , packageAsset = r t
+ , sourceFingerprint = T.encodeUtf8 body
}
+
+ where
+ r :: Template -> Map AssetId PublicIdentifier -> Either Error Result
+ r t m = do
+ body <- render t $ \(a,b) x -> do
+ case M.lookup (AssetId x) m of
+ Nothing -> Left (UndeclaredDependency (AssetId x))
+ Just (PublicIdentifier v) -> Right $ a <> v <> b
+
+ let body' = T.encodeUtf8 body
+ return $ Result (PublicIdentifier $ fingerprint body' src) $ Just (body', "text/javascript")
diff --git a/src/Data/Mole/Builder/Stylesheet.hs b/src/Data/Mole/Builder/Stylesheet.hs
--- a/src/Data/Mole/Builder/Stylesheet.hs
+++ b/src/Data/Mole/Builder/Stylesheet.hs
@@ -1,15 +1,14 @@
module Data.Mole.Builder.Stylesheet where
-import Control.Monad
+import Data.Traversable
import Data.Map (Map)
import qualified Data.Map as M
import qualified Data.Set as S
-import Data.ByteString.Char8 (pack)
-
+import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.Text.IO as T
@@ -25,43 +24,45 @@
-urlAssetId :: String -> AssetId
-urlAssetId x = case parseRelativeReference x of
- Nothing -> AssetId x
- Just uri -> AssetId $ uriPath uri
+tokenToAssetId :: Token -> Maybe AssetId
+tokenToAssetId (Url x) = Just $ urlAssetId x
+tokenToAssetId _ = Nothing
-reconstructUrl :: String -> String -> String
-reconstructUrl x pubId = case parseRelativeReference x of
+
+urlAssetId :: Text -> AssetId
+urlAssetId x = AssetId $ case parseRelativeReference (T.unpack x) of
+ Nothing -> x
+ Just uri -> T.pack $ uriPath uri
+
+
+reconstructUrl :: Text -> Text -> Text
+reconstructUrl x pubId = case parseRelativeReference (T.unpack x) of
Nothing -> pubId
- Just uri -> show $ uri { uriPath = pubId }
+ Just uri -> T.pack $ show $ uri { uriPath = T.unpack pubId }
-stylesheetBuilder :: String -> String -> Handle -> AssetId -> IO Builder
-stylesheetBuilder pubId src _ _ = do
+stylesheetBuilder :: String -> Handle -> AssetId -> IO Builder
+stylesheetBuilder src _ _ = do
body <- T.readFile src
let Right tokens = tokenize body
- let deps = catMaybes $ (flip map) tokens $ \t ->
- case t of
- (Url x) -> Just $ urlAssetId (T.unpack x)
- _ -> Nothing
return $ Builder
{ assetSources = S.singleton src
- , assetDependencies = S.fromList deps
- , packageAsset = r tokens
+ , assetDependencies = S.fromList (catMaybes $ map tokenToAssetId tokens)
+ , packageAsset = render tokens
+ , sourceFingerprint = T.encodeUtf8 body
}
where
- r :: [Token] -> Map AssetId String -> Either Error Result
- r tokens m = do
- newTokens <- forM tokens $ \t -> case t of
- (Url x) -> case M.lookup (urlAssetId (T.unpack x)) m of
- Nothing -> Left (UndeclaredDependency (AssetId (T.unpack x)))
- Just v -> Right (Url $ T.pack $ reconstructUrl (T.unpack x) v)
- _ -> return t
+ render :: [Token] -> Map AssetId PublicIdentifier -> Either Error Result
+ render tokens m = do
+ newTokens <- for tokens $ \t -> case t of
+ (Url x) -> case M.lookup (urlAssetId x) m of
+ Nothing -> Left (UndeclaredDependency (AssetId x))
+ Just (PublicIdentifier v) -> Right (Url $ reconstructUrl x v)
+ _ -> Right t
- let bodyT = serialize newTokens
- let body = T.unpack bodyT
+ let body = T.encodeUtf8 $ serialize newTokens
- return $ Result (fingerprint (pack body) pubId) $ Just (T.encodeUtf8 bodyT, "text/css")
+ return $ Result (PublicIdentifier $ fingerprint body src) $ Just (body, "text/css")
diff --git a/src/Data/Mole/Core.hs b/src/Data/Mole/Core.hs
--- a/src/Data/Mole/Core.hs
+++ b/src/Data/Mole/Core.hs
@@ -12,6 +12,9 @@
import Data.Set (Set)
import qualified Data.Set as S
+import Data.ByteString (ByteString)
+import qualified Data.Text as T
+
import Data.Maybe
import Data.Monoid
import Data.Time
@@ -20,6 +23,8 @@
import Data.Mole.Builder.External
import System.Environment
+import System.IO (hFlush, stdout)
+
import qualified Network.Kraken as K
@@ -39,9 +44,10 @@
(Message time aId msg) <- atomically $ readTQueue msgs
putStrLn $ mconcat
[ formatTime defaultTimeLocale "%H:%M:%S" time
- , " [ " <> take 24 (padL 24 (unAssetId aId)) <> " ] "
+ , " [ " <> take 24 (padL 24 (T.unpack $ unAssetId aId)) <> " ] "
, msg
]
+ hFlush stdout
e <- newTQueueIO
void $ forkIO $ forever $ do
@@ -55,17 +61,31 @@
let h = Handle st msgs e kH l
+
+ -- This background thread periodically checks if there are any assets
+ -- marked as dirty and forks a build thread for each.
tId <- forkIO $ forever $ do
- da <- dirtyAssets st
- forM_ da $ \aId -> do
- -- logger lock $ "Asset " ++ (show aId) ++ " is dirty. Building..."
+
+ -- Get a list of dirty assets. Those are the ones which we need to
+ -- rebuild. The check runs in a STM transaction, and will block until
+ -- at least one asset is dirty. Much efficient, wow.
+ dirtyAssetIds <- atomically $ do
+ s <- readTVar st
+ let assetIds = M.keys $ M.filter ((==) Dirty . arsState) (assets s)
+ if length assetIds == 0 then retry else return assetIds
+
+ forM_ dirtyAssetIds $ \aId -> do
+ -- First we have to mark the asset as being built. This is to avoid
+ -- forking two or more build threads for the same asset.
markBuilding h aId
+
forkIO $ do
assetDef <- lookupAssetDefinition config h aId
case assetDef of
- Nothing -> do -- failBuild h aId (AssetNotFound aId)
- logMessage h aId $ "Asset not found, treating as external!: " ++ show aId
- buildAsset h aId $ AssetDefinition (externalBuilder $ unAssetId aId) id (\_ _ _ -> return ())
+ Nothing -> do
+ -- failBuild h aId (AssetNotFound aId)
+ logMessage h aId $ "Asset not found, treating as external: " ++ show aId
+ buildAsset h aId $ AssetDefinition (externalBuilder $ PublicIdentifier $ unAssetId aId) id (\_ _ _ -> return ())
Just ad -> do
-- logMessage h aId $ "Building"
buildAsset h aId ad
@@ -80,100 +100,135 @@
atomically $ writeTQueue (messages h) (Message now aId msg)
-updateMetadata :: Handle -> AssetId -> Set FilePath -> Set AssetId -> IO ()
-updateMetadata h aId src ds = atomically $ do
- modifyTVar (state h) $ \s -> s { assets = M.adjust (\ars -> ars {
- arsSources = src, arsDependencySet = ds }) aId (assets s) }
+adjustAssetRuntimeState :: Handle -> AssetId -> (AssetRuntimeState -> AssetRuntimeState) -> IO ()
+adjustAssetRuntimeState h aId f = atomically $ do
+ modifyTVar (state h) $ \s -> s { assets = M.adjust f aId (assets s) }
+insertAssetRuntimeStateWith :: Handle -> AssetId -> (AssetRuntimeState -> AssetRuntimeState -> AssetRuntimeState) -> AssetRuntimeState -> IO ()
+insertAssetRuntimeStateWith h aId f d = atomically $ do
+ modifyTVar (state h) $ \s -> s { assets = M.insertWith f aId d (assets s) }
+
+updateMetadata :: Handle -> AssetId -> Set FilePath -> Set AssetId -> ByteString -> Map AssetId PublicIdentifier -> IO ()
+updateMetadata h aId src ds fp rd = adjustAssetRuntimeState h aId $ \ars -> ars
+ { arsSources = src
+ , arsDependencySet = ds
+ , arsSource = Just (fp, rd)
+ }
+
+
buildIfNecessary :: Handle -> AssetId -> IO ()
-buildIfNecessary h aId = atomically $ do
- modifyTVar (state h) $ \s -> s { assets = M.insertWith adj aId (AssetRuntimeState Dirty S.empty S.empty) (assets s) }
+buildIfNecessary h aId = insertAssetRuntimeStateWith h aId adj (assetRuntimeState Dirty)
where
adj _ ars = case arsState ars of
- Building -> ars
+ Building _ -> ars
Completed _ -> ars
- _ -> ars { arsState = Dirty }
+ _ -> ars { arsState = Dirty }
markDirty :: Handle -> AssetId -> IO ()
-markDirty h aId = atomically $ do
- modifyTVar (state h) $ \s -> s { assets = M.insertWith (\_ ars -> ars { arsState = Dirty }) aId (AssetRuntimeState Dirty S.empty S.empty) (assets s) }
+markDirty h aId = insertAssetRuntimeStateWith h aId f (assetRuntimeState Dirty)
+ where f _ ars = ars { arsState = Dirty }
markBuilding :: Handle -> AssetId -> IO ()
-markBuilding h aId = atomically $ do
- modifyTVar (state h) $ \s -> s { assets = M.insertWith (\_ ars -> ars { arsState = Building }) aId (AssetRuntimeState Building S.empty S.empty) (assets s) }
+markBuilding h aId = do
+ s <- Building <$> getCurrentTime
+ insertAssetRuntimeStateWith h aId (\_ ars -> ars { arsState = s }) (assetRuntimeState s)
failBuild :: Handle -> AssetId -> Error -> IO ()
failBuild h aId err = do
logMessage h aId $ "Failure: " ++ show err
- atomically $ do
- modifyTVar (state h) $ \s -> s { assets = M.adjust (\ars -> ars { arsState = Failed err }) aId (assets s) }
-
+ adjustAssetRuntimeState h aId $ \ars -> ars { arsState = Failed err }
rebuildReverseDependencies h aId
finishBuilding :: Handle -> AssetId -> Result -> IO ()
finishBuilding h aId res = do
- atomically $ do
- modifyTVar (state h) $ \s -> s { assets = M.adjust (\ars -> ars { arsState = Completed res }) aId (assets s) }
+ now <- getCurrentTime
+ let diff (Building t0) = diffUTCTime now t0
+ diff _ = fromIntegral (0 :: Int)
+
+ adjustAssetRuntimeState h aId $ \ars -> ars
+ { arsState = Completed (diff $ arsState ars)
+ , arsResult = Just res
+ }
+
+ mbArs <- atomically $ do
+ s <- readTVar (state h)
+ return $ M.lookup aId (assets s)
+
+ case mbArs of
+ Nothing -> return ()
+ Just ars -> case arsState ars of
+ Completed td -> logMessage h aId $ "Build time: " ++ show td
+ _ -> return ()
+
+
-- Go through all reverse dependencies and mark them as dirty.
rebuildReverseDependencies h aId
+isBuilding :: AssetState -> Bool
+isBuilding (Building _) = True
+isBuilding _ = False
+
+isFailed :: AssetState -> Bool
+isFailed (Failed _) = True
+isFailed _ = False
+
rebuildReverseDependencies :: Handle -> AssetId -> IO ()
rebuildReverseDependencies h aId = do
s <- atomically $ readTVar (state h)
forM_ (M.toList $ assets s) $ \(aId', ars) -> do
- when ((arsState ars /= Building) && S.member aId (arsDependencySet ars)) $ do
+ when ((not $ isBuilding $ arsState ars) && S.member aId (arsDependencySet ars)) $ do
markDirty h aId'
+-- | Wait until the set of assets is built, and return the corresponding
+-- results. If any of the assets fails to build (for whatever reason), then
+-- immediately abort and return the reason.
require :: Handle -> Set AssetId -> IO (Either Error (Map AssetId Result))
require h assetIds = do
-- Mark assets as dirty if they are not comleted yet.
- forM_ (S.toList assetIds) $ \dep -> do
+ forM_ assetIds $ \dep -> do
buildIfNecessary h dep
-- Wait for the dependencies to have completed building.
atomically $ do
s <- readTVar (state h)
- let de = filter (\(aId, _) -> S.member aId assetIds) (M.toList (assets s))
- let completedPubRefs = catMaybes $ map (\(aId, ars) -> case (arsState ars) of
- Completed res -> Just (aId, res)
- _ -> Nothing) de
+ -- All dependencies which are relevant.
+ let allDependencies = M.filterWithKey (\aId _ -> S.member aId assetIds) (assets s)
- if length completedPubRefs == length assetIds
- then return $ Right $ M.fromList completedPubRefs
- else if any (\(_, ars) -> case arsState ars of Failed _ -> True; _ -> False) de
+ -- The dependencies which are completed and for which we have a result.
+ let completedDependencies = flip M.mapMaybe allDependencies $ \ars -> case (arsState ars, arsResult ars) of
+ (Completed _, Just res) -> Just res
+ _ -> Nothing
+
+ -- A more accurate check would be 'assetIds == M.keysSet completedDependencies'.
+ -- Though comparing the length is probably faster.
+ if length completedDependencies == length assetIds
+ then return $ Right $ completedDependencies
+ else if any (isFailed . arsState) (M.elems allDependencies)
then return $ Left DependencyFailed
else retry
+
assetsByPublicIdentifier :: State -> PublicIdentifier -> [(AssetId, Result)]
assetsByPublicIdentifier st pubId = filter (\(_,res) -> publicIdentifier res == pubId) $
catMaybes $ map f $ M.assocs $ assets st
- where f (aId, AssetRuntimeState (Completed res) _ _) = Just (aId, res)
+ where f (aId, AssetRuntimeState (Completed _) _ _ _ (Just res)) = Just (aId, res)
f _ = Nothing
assetByPublicIdentifier :: State -> PublicIdentifier -> Maybe Result
assetByPublicIdentifier st pubId = lookup pubId $ catMaybes $ map f $ M.elems $ assets st
- where f (AssetRuntimeState (Completed res) _ _) = Just (publicIdentifier res, res)
+ where f (AssetRuntimeState (Completed _) _ _ _ (Just res)) = Just (publicIdentifier res, res)
f _ = Nothing
-
-dirtyAssets :: TVar State -> IO [AssetId]
-dirtyAssets st = atomically $ do
- s <- readTVar st
- let de = filter (\(_, ars) -> Dirty == arsState ars) $ M.toList (assets s)
- if length de == 0
- then retry
- else return $ map fst de
-
lookupAssetDefinition :: Config -> Handle -> AssetId -> IO (Maybe AssetDefinition)
lookupAssetDefinition config h aId = case M.lookup aId (assetDefinitions config) of
Just ad -> return $ Just ad
@@ -182,23 +237,51 @@
buildAsset :: Handle -> AssetId -> AssetDefinition -> IO ()
buildAsset h aId ad = do
- Builder src depSet cont <- createBuilder ad h aId
-
- updateMetadata h aId src depSet
+ Builder src depSet cont fp <- createBuilder ad h aId
- -- putStrLn $ "Waiting for " ++ show depSet
- rd <- require h depSet
- case rd of
+ eitherResolvedDeps <- require h depSet
+ case eitherResolvedDeps of
Left e -> failBuild h aId e
+
Right resolvedDeps -> do
- -- logger lock $ "Got all dependencies of " ++ show aId
- -- logger lock $ resolvedDeps
- case cont (M.map publicIdentifier resolvedDeps) of
- Left e -> failBuild h aId e
- Right result1@(Result pub _) -> do
- let result = result1 { publicIdentifier = transformPublicIdentifier ad pub }
- -- logger lock $ "Pub: " ++ (publicIdentifier result)
- -- logger lock $ res
+ let sourceDeps = M.map publicIdentifier resolvedDeps
- atomically $ writeTQueue (emitStream h) $ emitResult ad h aId result
- finishBuilding h aId result
+ -- First check if we actually need to rebuild the asset. If the source
+ -- fingerprint is still the same then we can skip directly to 'Completed'.
+ needsRebuild <- atomically $ do
+ s <- readTVar (state h)
+ return $ case M.lookup aId (assets s) of
+ Just (AssetRuntimeState _ _ _ (Just (sfp, srd)) (Just _)) -> sfp /= fp || sourceDeps /= srd
+ _ -> True
+
+ -- Eagerly update the metadata, even if we don't have to rebuild the asset.
+ -- When deciding whether to rebuild the asset or not, the only thing that
+ -- matters is the fingerprint. But the builder may have an updated or more
+ -- accurate set of dependencies now, and we do want to update that.
+ updateMetadata h aId src depSet fp sourceDeps
+
+
+ if not needsRebuild
+ then do
+ logMessage h aId $ "Skip"
+
+ now <- getCurrentTime
+
+ let diff (Building t0) = diffUTCTime now t0
+ diff _ = fromIntegral (0 :: Int)
+
+ adjustAssetRuntimeState h aId $ \ars ->
+ ars { arsState = Completed (diff $ arsState ars) }
+
+ else do
+ -- logger lock $ "Got all dependencies of " ++ show aId
+ -- logger lock $ resolvedDeps
+ case cont (M.map publicIdentifier resolvedDeps) of
+ Left e -> failBuild h aId e
+ Right result1@(Result pub _) -> do
+ let result = result1 { publicIdentifier = transformPublicIdentifier ad pub }
+ -- logger lock $ "Pub: " ++ (publicIdentifier result)
+ -- logger lock $ res
+
+ atomically $ writeTQueue (emitStream h) $ emitResult ad h aId result
+ finishBuilding h aId result
diff --git a/src/Data/Mole/Server.hs b/src/Data/Mole/Server.hs
--- a/src/Data/Mole/Server.hs
+++ b/src/Data/Mole/Server.hs
@@ -14,7 +14,7 @@
import Data.Maybe
import Data.List (find)
-import Snap.Http.Server (simpleHttpServe, setAccessLog, setErrorLog, ConfigLog(..), emptyConfig)
+import Snap.Http.Server (httpServe, ConfigLog(..))
import qualified Snap.Http.Server.Config as SC
import Snap (Snap, pass, getRequest, rqPathInfo, setContentType, modifyResponse, writeBS)
@@ -23,13 +23,14 @@
-serveFiles :: Handle -> Int -> IO ()
-serveFiles h port = do
+serveFiles :: Handle -> Int -> Maybe String -> IO ()
+serveFiles h port mbSocketPath = do
snapConfig <- do
- config <- return emptyConfig :: IO (SC.Config Snap ())
- return $ setAccessLog ConfigNoLog $ setErrorLog ConfigNoLog config
+ config <- return SC.emptyConfig :: IO (SC.Config Snap ())
+ let config' = SC.setAccessLog ConfigNoLog $ SC.setErrorLog ConfigNoLog config
+ return $ maybe (SC.setPort port config') (\x -> SC.setUnixSocket x config') mbSocketPath
- simpleHttpServe (SC.setPort port snapConfig) (snapHandler h)
+ httpServe snapConfig (snapHandler h)
@@ -46,7 +47,7 @@
serve p = do
s <- liftIO $ atomically $ readTVar (state h)
- let asts = assetsByPublicIdentifier s (T.unpack $ T.decodeUtf8 p)
+ let asts = assetsByPublicIdentifier s (PublicIdentifier $ T.decodeUtf8 p)
-- liftIO $ print asts
if length asts == 0
then pass
diff --git a/src/Data/Mole/Types.hs b/src/Data/Mole/Types.hs
--- a/src/Data/Mole/Types.hs
+++ b/src/Data/Mole/Types.hs
@@ -6,7 +6,10 @@
import Data.ByteString (ByteString)
import Data.Map (Map)
import Data.Set (Set)
-import Data.Time (UTCTime)
+import qualified Data.Set as S
+import Data.Time (UTCTime, NominalDiffTime)
+import Data.Text (Text)
+import qualified Data.Text as T
import qualified Network.Kraken as K
@@ -18,11 +21,11 @@
--
-- Even though the 'AssetId' may look like a filename or path, it doesn't have
-- to refer to an actual file in the filesystem.
-newtype AssetId = AssetId { unAssetId :: String }
+newtype AssetId = AssetId { unAssetId :: Text }
deriving (Ord, Eq)
instance Show AssetId where
- show = unAssetId
+ show = T.unpack . unAssetId
newtype BuildId = BuildId { unBuildId :: Int }
@@ -31,7 +34,21 @@
type ContentType = String
-data AssetState = Dirty | Building | Failed Error | Completed Result
+data AssetState
+ = Dirty
+ -- ^ The asset is marked as dirty and needs to be built when some other
+ -- asset depends on it.
+
+ | Building !UTCTime
+ -- ^ A thread is currently building the asset. The timestamp is the time
+ -- when the thread was forked. It is used to keep track how long it took
+ -- to build the asset.
+
+ | Failed Error
+
+ | Completed !NominalDiffTime
+ -- ^ The asset is available. The time is how long it took to build it.
+
deriving (Eq, Show)
@@ -65,13 +82,50 @@
data AssetRuntimeState = AssetRuntimeState
{ arsState :: AssetState
+
, arsSources :: Set FilePath
+ -- ^ This is a approximation of the set of files which make up the asset.
+ -- When any of these files change, the asset is marked as dirty.
+
, arsDependencySet :: Set AssetId
+ -- ^ Assets which are depended on. These must be built before this asset
+ -- can be further processed. Also, if any of the dependencies changes,
+ -- this asset is rebuilt as well.
+
+ , arsSource :: Maybe (ByteString, Map AssetId PublicIdentifier)
+ -- ^ This is used to avoid processing the file when its contents have
+ -- not changed. The first element of the tuple is the file contents or
+ -- fingerprint (hash), the second element are the resolved dependencies.
+ -- If the two are same, then the result SHOULD as well.
+
+ , arsResult :: Maybe Result
+ -- ^ If the asset is built, this is the result. This can be set even
+ -- if the state is not 'Completed'. This is the case when the asset
+ -- is being rebuilt. If the state is not 'Completed' you should wait for
+ -- it to reach that state before using the result, otherwise you may
+ -- get a stale result.
} deriving (Show)
-type PublicIdentifier = String
+-- | The initial, empty 'AssetRuntimeState', with the given 'AssetState'
+-- (usually 'Dirty' or 'Building' depending at which stage it is created).
+assetRuntimeState :: AssetState -> AssetRuntimeState
+assetRuntimeState s = AssetRuntimeState
+ { arsState = s
+ , arsSources = S.empty
+ , arsDependencySet = S.empty
+ , arsSource = Nothing
+ , arsResult = Nothing
+ }
+
+-- | This is how one can refer to processed assets. Probably should be a newtype
+-- around 'URL', because that's what those really are (well, just the path part
+-- of an URL).
+newtype PublicIdentifier = PublicIdentifier { unPublicIdentifier :: Text }
+ deriving (Eq, Show)
+
+
data Result = Result
{ publicIdentifier :: PublicIdentifier
-- ^ This is how other parts of the application can refer to the asset.
@@ -106,6 +160,13 @@
, packageAsset :: Map AssetId PublicIdentifier -> Either Error Result
-- ^ A function which takes the public identifiers for all dependencies
-- and creates the final asset package.
+
+ , sourceFingerprint :: ByteString
+ -- ^ Fingerprint of all sources which make up the asset. This can be the
+ -- hash of all the input files, or the contents themselves (if not too
+ -- large). This is used to avoid rebuilding the asset if the input hasn't
+ -- actually changed. Often only the atime changes, but that has
+ -- no relevance on the output.
}
diff --git a/src/Data/Mole/Watcher.hs b/src/Data/Mole/Watcher.hs
--- a/src/Data/Mole/Watcher.hs
+++ b/src/Data/Mole/Watcher.hs
@@ -33,7 +33,7 @@
let p = eventPath ev
rd <- reverseDependencies h cwd p
forM_ rd $ \aId -> do
- logMessage h aId $ "Rebuilding because " ++ p ++ " was modified"
+ logMessage h aId $ "Dirty (" ++ p ++ ")"
markDirty h aId
atomically $ modifyTVar (state h) (\s -> s { stopFileWatcher = stop })
diff --git a/src/Main.hs b/src/Main.hs
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -5,6 +5,7 @@
import Control.Concurrent.STM
import Control.Monad
import Control.Monad.Reader
+import Control.Monad.Trans.Except
import Control.Applicative
import Data.Map (Map)
@@ -14,6 +15,7 @@
import qualified Data.ByteString as BS
+import Data.Text (Text)
import qualified Data.Text as T
import Data.Monoid
@@ -57,7 +59,7 @@
data Command
= Version
| Build !FilePath
- | Serve !Int
+ | Serve !Int !(Maybe FilePath)
run :: Options -> Command -> IO ()
@@ -80,7 +82,7 @@
e <- isEmptyTQueue (emitStream h)
unless e retry
-run opt (Serve port) = do
+run opt (Serve port mbSocketPath) = do
config <- mkConfig opt ""
h <- newHandle config
@@ -91,7 +93,7 @@
forM_ (entryPoints config) $ \aId ->
markDirty h aId
- serveFiles h port
+ serveFiles h port mbSocketPath
collectAssetDefinitions :: FilePath -> FilePath -> IO (Map AssetId AssetDefinition)
@@ -100,7 +102,7 @@
where
f m fi = if takeExtension p == ".html"
then M.insert
- (AssetId $ drop (length basePath + 1) $ p)
+ (AssetId $ T.pack $ drop (length basePath + 1) $ p)
(AssetDefinition (builderForFile basePath p) transformPublicIdentifierDef (emitResultDef outputDir))
m
else m
@@ -108,8 +110,10 @@
transformPublicIdentifierDef :: PublicIdentifier -> PublicIdentifier
-transformPublicIdentifierDef ('/':pubId) = '/' : pubId
-transformPublicIdentifierDef pubId = '/' : pubId
+transformPublicIdentifierDef pubId = case T.uncons $ unPublicIdentifier pubId of
+ Nothing -> pubId
+ Just ('/', _) -> pubId
+ _ -> PublicIdentifier $ T.cons '/' $ unPublicIdentifier pubId
locateSource :: Options -> AssetId -> IO (Maybe (String, String))
@@ -126,15 +130,15 @@
f = do
p <- filePath
t <- fileType
- return $ t == RegularFile && isSuffixOf aId p
+ return $ t == RegularFile && isSuffixOf (T.unpack aId) p
defAutoDiscovery :: Options -> FilePath -> Handle -> AssetId -> IO (Maybe AssetDefinition)
defAutoDiscovery opt outputDir _ (AssetId aId)
| aId == "" = do
- return $ Just $ AssetDefinition (externalBuilder aId) id (emitResultDef outputDir)
- | isURI aId = do
- return $ Just $ AssetDefinition (externalBuilder aId) id (emitResultDef outputDir)
+ return $ Just $ AssetDefinition (externalBuilder $ PublicIdentifier aId) id (emitResultDef outputDir)
+ | isURI $ T.unpack aId = do
+ return $ Just $ AssetDefinition (externalBuilder $ PublicIdentifier aId) id (emitResultDef outputDir)
-- | head aId == '/' = do
-- logMessage h (AssetId aId) $ "Starts with a slash, treating as external!"
-- return $ Just $ AssetDefinition (externalBuilder aId) id (emitResultDef outputDir)
@@ -154,8 +158,8 @@
Nothing -> return ()
Just (body, _) -> when (dist /= "") $ do
-- putStrLn $ "emit " ++ pubId
- createDirectoryIfMissing True $ dist `joinDrive` (takeDirectory pubId)
- BS.writeFile (dist `joinDrive` pubId) body
+ createDirectoryIfMissing True $ dist `joinDrive` (takeDirectory $ T.unpack $ unPublicIdentifier pubId)
+ BS.writeFile (dist `joinDrive` T.unpack (unPublicIdentifier pubId)) body
mkConfig :: Options -> FilePath -> IO Config
@@ -167,7 +171,7 @@
return (aId, ad)
let allAssets = M.fromList oAssets <> otherAssets
- let allEntryPoints = filter (\(AssetId a) -> T.isSuffixOf ".html" (T.pack a)) $ M.keys allAssets
+ let allEntryPoints = filter (\(AssetId a) -> T.isSuffixOf ".html" a) $ M.keys allAssets
-- print $ M.keys allAssets
-- let otherAssets = M.fromList $ (flip map) (optEntryPoints opt) $ \(AssetId aId) ->
@@ -208,19 +212,21 @@
parseServe :: Parser Command
parseServe = Serve
<$> option auto (long "port" <> short 'p' <> metavar "PORT" <> value 8000)
+ <*> option (Just <$> str) (long "socket-path" <> short 'u' <> metavar "SOCKET-PATH" <> value Nothing)
+askText :: ReaderT String (Except ParseError) Text
+askText = T.pack <$> ask
+
assetIdRead :: ReadM AssetId
-assetIdRead = ReadM $ do
- v <- ask
- return $ AssetId v
+assetIdRead = ReadM $ AssetId <$> askText
data AssetType = Ext | Raw
assetRead :: AssetType -> ReadM (AssetId, Options -> String -> IO AssetDefinition)
assetRead at = ReadM $ do
- v <- ask
- case map T.unpack $ T.splitOn "=" $ T.pack v of
- [aId, p] -> return $ ad aId p
+ v <- askText
+ case T.splitOn "=" v of
+ [aId, p] -> return $ ad aId $ PublicIdentifier p
_ -> fail "ASSET=DEFINITION"
where
@@ -231,7 +237,7 @@
, \opt outputDir -> do
mbSource <- locateSource opt (AssetId aId)
case mbSource of
- Nothing -> error $ "Could not find asset " ++ aId
+ Nothing -> error $ "Could not find asset " ++ T.unpack aId
Just (_, p') -> do
return $ AssetDefinition (rawBuilder p p' "application/octet-stream") transformPublicIdentifierDef (emitResultDef outputDir)
)
@@ -251,8 +257,8 @@
( long "paths" <> short 'p' <> metavar "SEARCH:PATH:DIRS:..."<> value ["assets/"] )
where
pathRead = ReadM $ do
- v <- ask
- case map T.unpack $ T.splitOn ":" $ T.pack v of
+ v <- askText
+ case map T.unpack $ T.splitOn ":" v of
(x:xs) -> return $ x:xs
_ -> fail "SEARCH:PATH:DIRS:..."
diff --git a/test/Test.hs b/test/Test.hs
--- a/test/Test.hs
+++ b/test/Test.hs
@@ -1,4 +1,5 @@
-{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
module Main where
@@ -24,33 +25,41 @@
import Data.Mole.Builder.Internal.Template
+instance Serial IO Text where
+ series = T.pack <$> series
+
main :: IO ()
main = do
hspec $ spec
+bracket :: Bracket
+bracket = ("<*","*>")
+brackets :: Brackets
+brackets = [bracket]
+
spec :: Spec
spec = do
describe "Data.Mole.Builder.Internal.Template" $ do
it "should parse a non-empty string into a single literal" $ do
- property $ \x -> length x > 0 ==>
- template x == Template [Lit $ T.pack x]
+ property $ \x -> T.length x > 0 ==>
+ template brackets x == Template [Lit x]
it "should strip whitespace around a var" $ do
- template "<* \nvar \t *>" `shouldBe`
- Template [ Var "var" ]
+ template brackets "<* \nvar \t *>" `shouldBe`
+ Template [ Var bracket "var" ]
it "should parse a string with a var in it" $ do
- template "some <* var *> template" `shouldBe`
- Template [ Lit "some ", Var "var", Lit " template" ]
+ template brackets "some <* var *> template" `shouldBe`
+ Template [ Lit "some ", Var bracket "var", Lit " template" ]
it "should parse two directly adjacent vars" $ do
- template "<* v1 *><* v2 *>" `shouldBe`
- Template [ Var "v1", Var "v2" ]
+ template brackets "<* v1 *><* v2 *>" `shouldBe`
+ Template [ Var bracket "v1", Var bracket "v2" ]
it "should parse two adjacent vars with a whitespace in between" $ do
- template "<* v1 *> <* v2 *>" `shouldBe`
- Template [ Var "v1", Lit " ", Var "v2" ]
+ template brackets "<* v1 *> <* v2 *>" `shouldBe`
+ Template [ Var bracket "v1", Lit " ", Var bracket "v2" ]
it "should ignore a false start of a var" $ do
- template "