mole 0.0.3 → 0.0.5
raw patch · 16 files changed
+553/−318 lines, 16 filesdep ~basedep ~fsnotify
Dependency ranges changed: base, fsnotify
Files
- mole.cabal +71/−84
- src/Data/Mole/Builder.hs +1/−1
- src/Data/Mole/Builder/Binary.hs +3/−1
- src/Data/Mole/Builder/External.hs +11/−0
- src/Data/Mole/Builder/Html.hs +73/−57
- src/Data/Mole/Builder/Image.hs +4/−2
- src/Data/Mole/Builder/Internal/Fingerprint.hs +12/−8
- src/Data/Mole/Builder/Internal/Template.hs +48/−23
- src/Data/Mole/Builder/JavaScript.hs +31/−4
- src/Data/Mole/Builder/Stylesheet.hs +29/−28
- src/Data/Mole/Core.hs +143/−60
- src/Data/Mole/Server.hs +8/−7
- src/Data/Mole/Types.hs +66/−5
- src/Data/Mole/Watcher.hs +1/−1
- src/Main.hs +28/−22
- test/Test.hs +24/−15
mole.cabal view
@@ -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
src/Data/Mole/Builder.hs view
@@ -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"
src/Data/Mole/Builder/Binary.hs view
@@ -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 }
src/Data/Mole/Builder/External.hs view
@@ -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:+--+-- <meta name="version" content="VERSION" />+--+-- 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 }
src/Data/Mole/Builder/Html.hs view
@@ -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")
src/Data/Mole/Builder/Image.hs view
@@ -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 }
src/Data/Mole/Builder/Internal/Fingerprint.hs view
@@ -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
src/Data/Mole/Builder/Internal/Template.hs view
@@ -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
src/Data/Mole/Builder/JavaScript.hs view
@@ -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")
src/Data/Mole/Builder/Stylesheet.hs view
@@ -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")
src/Data/Mole/Core.hs view
@@ -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
src/Data/Mole/Server.hs view
@@ -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
src/Data/Mole/Types.hs view
@@ -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. }
src/Data/Mole/Watcher.hs view
@@ -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 })
src/Main.hs view
@@ -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:..."
test/Test.hs view
@@ -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 "<div><a href='<* var *>'>link</a></div>" `shouldBe`- Template [ Lit "<div><a href='", Var "var", Lit "'>link</a></div>" ]+ template brackets "<div><a href='<* var *>'>link</a></div>" `shouldBe`+ Template [ Lit "<div><a href='", Var bracket "var", Lit "'>link</a></div>" ] it "should allow literals between two false starts" $ do- template "<div> <hr> <* var *> <br>" `shouldBe`- Template [ Lit "<div> <hr> ", Var "var", Lit " <br>" ]+ template brackets "<div> <hr> <* var *> <br>" `shouldBe`+ Template [ Lit "<div> <hr> ", Var bracket "var", Lit " <br>" ]