packages feed

mole 0.0.2 → 0.0.3

raw patch · 14 files changed

+966/−4 lines, 14 filesdep −system-filepathdep ~fsnotify

Dependencies removed: system-filepath

Dependency ranges changed: fsnotify

Files

mole.cabal view
@@ -1,5 +1,5 @@ name:                mole-version:             0.0.2+version:             0.0.3  synopsis:            A glorified string replacement tool description:@@ -29,10 +29,26 @@     hs-source-dirs:      src     default-language:    Haskell2010 -    ghc-options:         -Wall -threaded -O2 -rtsopts+    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+     build-depends:        base >=4.6 && <4.9      , containers@@ -43,9 +59,8 @@      , cryptohash      , filepath      , filemanip-     , fsnotify+     , fsnotify >=0.2      , directory-     , system-filepath      , snap      , snap-server      , text
+ src/Data/Mole/Builder.hs view
@@ -0,0 +1,23 @@+module Data.Mole.Builder where+++import           Data.Mole.Types+import           Data.Mole.Builder.Html+import           Data.Mole.Builder.Binary+import           Data.Mole.Builder.JavaScript+import           Data.Mole.Builder.Image+import           Data.Mole.Builder.Stylesheet++import           System.FilePath++++builderForFile :: FilePath -> String -> Handle -> AssetId -> IO Builder+builderForFile basePath x = case takeExtension x of+    ".css"  -> stylesheetBuilder x x+    ".html" -> htmlBuilder (drop (length basePath) x) x+    ".js"   -> javascriptBuilder x+    ".png"  -> imageBuilder x "image/png"+    ".jpeg" -> imageBuilder x "image/jpeg"+    ".jpg"  -> imageBuilder x "image/jpeg"+    _       -> binaryBuilder x "application/octet-stream"
+ src/Data/Mole/Builder/Binary.hs view
@@ -0,0 +1,31 @@+module Data.Mole.Builder.Binary where+++import qualified Data.Set as S++import qualified Data.ByteString as BS++import           Data.Mole.Types+import           Data.Mole.Builder.Internal.Fingerprint++++binaryBuilder :: String -> String -> Handle -> AssetId -> IO Builder+binaryBuilder src contentType _ _ = do+    body <- BS.readFile src+    return $ Builder+        { assetSources      = S.singleton src+        , assetDependencies = S.empty+        , packageAsset      = const $ Right $ Result (fingerprint body src) $ Just (body, contentType)+        }+++-- | Like the 'binaryBuilder', but does not fingerprint the asset.+rawBuilder :: PublicIdentifier -> String -> String -> Handle -> AssetId -> IO Builder+rawBuilder pubId src contentType _ _ = do+    body <- BS.readFile src+    return $ Builder+        { assetSources      = S.singleton src+        , assetDependencies = S.empty+        , packageAsset      = const $ Right $ Result pubId (Just (body, contentType))+        }
+ src/Data/Mole/Builder/External.hs view
@@ -0,0 +1,16 @@+module Data.Mole.Builder.External where+++import qualified Data.Set as S++import           Data.Mole.Types++++externalBuilder :: PublicIdentifier -> Handle -> AssetId -> IO Builder+externalBuilder pubId _ _ = do+    return $ Builder+        { assetSources      = S.empty+        , assetDependencies = S.empty+        , packageAsset      = const $ Right $ Result pubId Nothing+        }
+ src/Data/Mole/Builder/Html.hs view
@@ -0,0 +1,132 @@+module Data.Mole.Builder.Html+    ( htmlBuilder+    ) where+++import           Control.Monad++import           Data.Map (Map)+import qualified Data.Map as M++import qualified Data.Set as S++import qualified Data.Text          as T+import qualified Data.Text.Encoding as T++import           Data.Maybe+import           Data.CSS.Syntax.Tokens++import           Text.HTML.TagSoup++import           Data.Mole.Types+import           Data.Mole.Builder.Stylesheet++++data Transformer = Transformer+    { tagSelector       :: String -> Bool+    , attributeName     :: String+    , depExtractor      :: String -> [AssetId]+    , attributeRenderer :: Map AssetId String -> String -> Either Error String+    }++extractSingleAsset :: String -> [AssetId]+extractSingleAsset x = [AssetId x]++renderSingleAttribute :: Map AssetId String -> String -> Either Error String+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))++extractStylesheetAssets :: String -> [AssetId]+extractStylesheetAssets v =+    let Right tokens = tokenize (T.pack v)+    in catMaybes $ (flip map) tokens $ \t ->+            case t of+                (Url x) -> Just $ urlAssetId (T.unpack x)+                _       -> Nothing++renderStylesheetAssets :: Map AssetId String -> String -> Either Error String+renderStylesheetAssets m v = do+    let Right tokens = tokenize (T.pack 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)+        _ -> return t++    return $ T.unpack $ serialize newTokens++tagTransformers :: [Transformer]+tagTransformers =+    [ Transformer ("link"==)   "href"    extractSingleAsset renderSingleAttribute+    , Transformer ("img"==)    "src"     extractSingleAsset renderSingleAttribute+    , Transformer ("script"==) "src"     extractSingleAsset renderSingleAttribute+    , Transformer ("a"==)      "href"    extractSingleAsset renderSingleAttribute+    , Transformer ("meta"==)   "content" extractSingleAsset renderSingleAttribute+    , Transformer (const True) "style"   extractStylesheetAssets renderStylesheetAssets+    ]++tagTransformersFor :: String -> [Transformer]+tagTransformersFor tag = filter (\t -> tagSelector t tag) tagTransformers+++toInlineStyleDep :: [AssetId] -> [Tag String] -> [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++renderInlineStyles :: Map AssetId String -> [Tag String] -> Either Error [Tag String]+renderInlineStyles m [] = return []+renderInlineStyles m ((TagOpen "style" attrs):(TagText text):(TagClose "style"):xs) = do+    text' <- renderStylesheetAssets m text+    rest  <- renderInlineStyles m xs+    return $ (TagOpen "style" attrs) : (TagText text') : (TagClose "style") : rest+renderInlineStyles m (x:xs) = do+    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 _ = []++    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'++        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++        TagOpen <$> (pure tag) <*> foldM f attrs tfs++    insertResult _ t = pure t++    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)
+ src/Data/Mole/Builder/Image.hs view
@@ -0,0 +1,76 @@+module Data.Mole.Builder.Image where+++import           Control.Concurrent.STM++import qualified Data.Set as S+import qualified Data.ByteString as BS+import           Data.Maybe+import           Data.Time+import           Text.Printf++import           Data.Mole.Types+import           Data.Mole.Builder.Internal.Fingerprint++import qualified Network.Kraken as K++import           System.Environment+import           System.FilePath+import           System.Directory+import           System.Posix.Files+++imageBuilder :: String -> String -> Handle -> AssetId -> IO Builder+imageBuilder src contentType h aId = do+    originalBody <- BS.readFile src+    let fp = contentHash originalBody+    cacheDir <- lookupEnv "XDG_CACHE_DIR"+    let cacheName = (fromMaybe ".cache" cacheDir) </> "kraken" </> fp+    inCache <- fileExist cacheName+    body <- if inCache+        then do BS.readFile cacheName+        else case krakenH h of+            Nothing -> return originalBody+            Just kh -> do+                atomically $ takeTMVar (lock h)+                logMessage' h aId $ "Compressing image with Kraken..."+                res <- K.compressImage kh (K.Options Nothing Nothing Nothing) originalBody+                case res of+                    Left _ -> do+                        atomically $ putTMVar (lock h) ()+                        return originalBody+                    Right body -> do+                        createDirectoryIfMissing True $ takeDirectory cacheName+                        BS.writeFile cacheName body++                        atomically $ putTMVar (lock h) ()++                        return body++    let ol = BS.length originalBody+    let nl = BS.length body++    let ratio :: Double+        ratio = (100.0 * ((fromIntegral nl :: Double) / (fromIntegral ol)))+    logMessage' h aId $ concat+        [ "Compressed image from "+        , show ol+        , " to "+        , show nl+        , " bytes ("+        , printf "%.2f" ratio+        , "%)"+        ]+++    return $ Builder+        { assetSources      = S.singleton src+        , assetDependencies = S.empty+        , packageAsset      = const $ Right $ Result (fingerprint body src) $ Just (body, contentType)+        }+++logMessage' :: Handle -> AssetId -> String -> IO ()+logMessage' h aId msg = do+    now <- getCurrentTime+    atomically $ writeTQueue (messages h) (Message now aId msg)
+ src/Data/Mole/Builder/Internal/Fingerprint.hs view
@@ -0,0 +1,40 @@+module Data.Mole.Builder.Internal.Fingerprint+    ( contentHash+    , fingerprint+    ) where+++import           Data.ByteString (ByteString)+import qualified Data.ByteString as BS+import           Data.ByteString.Char8 (unpack)+import           Data.Word++import           Crypto.Hash.SHA3++import           System.FilePath++++contentHash :: ByteString -> String+contentHash body =  unpack $ BS.map (\x -> alnum $ rem x 62) $ hash 512 body+  where+    alnum :: Word8 -> Word8+    alnum x+        | x < 26 = ((x     ) + 65)+        | x < 52 = ((x - 26) + 97)+        | x < 62 = ((x - 52) + 48)+        | otherwise = error $ "Out of range: " ++ show x+++fingerprint :: ByteString -> String -> String+fingerprint body name = mconcat+    [ take prefixLength h+    , "-"+    , takeBaseName name+    , "-"+    , drop prefixLength h+    , takeExtension name+    ]+  where+    h = contentHash body+    prefixLength = 9
+ src/Data/Mole/Builder/Internal/Template.hs view
@@ -0,0 +1,53 @@+{-# LANGUAGE OverloadedStrings #-}++module Data.Mole.Builder.Internal.Template where+++import           Control.Applicative++import           Data.Text (Text)+import qualified Data.Text as T++import qualified Data.Attoparsec.Text as AP++import           Data.Monoid+import           Data.Mole.Types++++type Context = Text -> Either Error Text+data Fragment = Lit Text | Var 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++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++fragmentParser :: AP.Parser [Fragment]+fragmentParser = var <|> lit+  where+    var = do+        text <- AP.string "<*" *> AP.manyTill AP.anyChar (AP.string "*>")+        return $ [Var $ T.strip $ T.pack text]++    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])++render :: Template -> Context -> Either Error String+render (Template frags) ctxFunc = do+    res <- traverse renderFrag frags+    return $ T.unpack $ mconcat res+  where+    renderFrag (Lit s) = pure s+    renderFrag (Var x) = ctxFunc x
+ src/Data/Mole/Builder/JavaScript.hs view
@@ -0,0 +1,20 @@+module Data.Mole.Builder.JavaScript where+++import qualified Data.Set as S++import qualified Data.ByteString as BS++import           Data.Mole.Types+import           Data.Mole.Builder.Internal.Fingerprint++++javascriptBuilder :: String -> Handle -> AssetId -> IO Builder+javascriptBuilder src _ _ = do+    body <- BS.readFile src+    return $ Builder+        { assetSources      = S.singleton src+        , assetDependencies = S.empty+        , packageAsset      = const $ Right $ Result (fingerprint body src) $ Just (body, "text/javascript")+        }
+ src/Data/Mole/Builder/Stylesheet.hs view
@@ -0,0 +1,67 @@+module Data.Mole.Builder.Stylesheet where+++import           Control.Monad++import           Data.Map (Map)++import qualified Data.Map as M+import qualified Data.Set as S++import           Data.ByteString.Char8 (pack)++import qualified Data.Text          as T+import qualified Data.Text.Encoding as T+import qualified Data.Text.IO       as T++import           Data.Maybe++import           Data.Mole.Types+import           Data.Mole.Builder.Internal.Fingerprint++import           Data.CSS.Syntax.Tokens++import           Network.URI++++urlAssetId :: String -> AssetId+urlAssetId x = case parseRelativeReference x of+    Nothing -> AssetId x+    Just uri -> AssetId $ uriPath uri++reconstructUrl :: String -> String -> String+reconstructUrl x pubId = case parseRelativeReference x of+    Nothing -> pubId+    Just uri -> show $ uri { uriPath = pubId }+++stylesheetBuilder :: String -> String -> Handle -> AssetId -> IO Builder+stylesheetBuilder pubId 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+        }++  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++        let bodyT = serialize newTokens+        let body = T.unpack bodyT++        return $ Result (fingerprint (pack body) pubId) $ Just (T.encodeUtf8 bodyT, "text/css")
+ src/Data/Mole/Core.hs view
@@ -0,0 +1,204 @@+module Data.Mole.Core where+++import           Control.Concurrent+import           Control.Concurrent.STM+import           Control.Monad+import           Control.Monad.Trans.Maybe++import           Data.Map (Map)+import qualified Data.Map as M++import           Data.Set (Set)+import qualified Data.Set as S++import           Data.Maybe+import           Data.Monoid+import           Data.Time++import           Data.Mole.Types+import           Data.Mole.Builder.External++import           System.Environment+import qualified Network.Kraken as K++++padL :: Int -> String -> String+padL n s+    | length s < n  = s ++ replicate (n - length s) ' '+    | otherwise     = s++newHandle :: Config -> IO Handle+newHandle config = do+    st <- newTVarIO $ State Nothing (return ()) M.empty+    l <- newTMVarIO ()++    msgs <- newTQueueIO+    void $ forkIO $ forever $ do+        (Message time aId msg) <- atomically $ readTQueue msgs+        putStrLn $ mconcat+            [ formatTime defaultTimeLocale "%H:%M:%S" time+            , " [ " <> take 24 (padL 24 (unAssetId aId)) <> " ] "+            , msg+            ]++    e <- newTQueueIO+    void $ forkIO $ forever $ do+        join $ atomically $ readTQueue e++    kH <- runMaybeT $ do+        apiKey <- MaybeT $ lookupEnv "KRAKEN_API_KEY"+        apiSecret <- MaybeT $ lookupEnv "KRAKEN_API_SECRET"++        MaybeT $ Just <$> K.newHandle (K.Config apiKey apiSecret)++    let h = Handle st msgs e kH l++    tId <- forkIO $ forever $ do+        da <- dirtyAssets st+        forM_ da $ \aId -> do+            -- logger lock $ "Asset " ++ (show aId) ++ " is dirty. Building..."+            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 ())+                    Just ad -> do+                        -- logMessage h aId $ "Building"+                        buildAsset h aId ad++    atomically $ modifyTVar st (\s -> s { dispatcherThreadId = Just tId })++    return h++logMessage :: Handle -> AssetId -> String -> IO ()+logMessage h aId msg = do+    now <- getCurrentTime+    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) }+++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) }+  where+    adj _ ars = case arsState ars of+        Building -> ars+        Completed _ -> ars+        _        -> 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) }+++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) }+++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) }++    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) }++    -- Go through all reverse dependencies and mark them as dirty.+    rebuildReverseDependencies h aId+++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+            markDirty h aId'+++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+        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++        if length completedPubRefs == length assetIds+            then return $ Right $ M.fromList completedPubRefs+            else if any (\(_, ars) -> case arsState ars of Failed _ -> True; _ -> False) de+                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)+        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)+        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+    Nothing -> autoDiscovery config h aId+++buildAsset :: Handle -> AssetId -> AssetDefinition -> IO ()+buildAsset h aId ad = do+    Builder src depSet cont <- createBuilder ad h aId++    updateMetadata h aId src depSet++    -- putStrLn $ "Waiting for " ++ show depSet+    rd <- require h depSet+    case rd 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++                    atomically $ writeTQueue (emitStream h) $ emitResult ad h aId result+                    finishBuilding h aId result
+ src/Data/Mole/Server.hs view
@@ -0,0 +1,63 @@+{-# LANGUAGE OverloadedStrings #-}++module Data.Mole.Server where+++import           Control.Concurrent.STM+import           Control.Monad.IO.Class+import           Control.Applicative++import qualified Data.Text          as T+import qualified Data.Text.Encoding as T++import           Data.Monoid+import           Data.Maybe+import           Data.List (find)++import           Snap.Http.Server (simpleHttpServe, setAccessLog, setErrorLog, ConfigLog(..), emptyConfig)+import qualified Snap.Http.Server.Config as SC+import           Snap (Snap, pass, getRequest, rqPathInfo, setContentType, modifyResponse, writeBS)++import           Data.Mole.Types+import           Data.Mole.Core++++serveFiles :: Handle -> Int -> IO ()+serveFiles h port = do+    snapConfig <- do+        config <- return emptyConfig :: IO (SC.Config Snap ())+        return $ setAccessLog ConfigNoLog $ setErrorLog ConfigNoLog config++    simpleHttpServe (SC.setPort port snapConfig) (snapHandler h)++++snapHandler :: Handle -> Snap ()+snapHandler h = do+    req <- getRequest+    serve ("/" <> rqPathInfo req)+        <|> serve ("/" <> rqPathInfo req <> "/index.html")+        <|> serve ("/" <> rqPathInfo req <> "index.html")+        <|> serve "/index.html"+        <|> writeBS ("Asset " <> rqPathInfo req <> " not found")++  where+    serve p = do+      s <- liftIO $ atomically $ readTVar (state h)++      let asts = assetsByPublicIdentifier s (T.unpack $ T.decodeUtf8 p)+    --   liftIO $ print asts+      if length asts == 0+          then pass+          else do+              -- void $ liftIO $ require h $ S.fromList $ map fst asts+              -- void $ liftIO $ require h $ S.singleton $ AssetId $ tail $ unpack p++              let mbRes = find (\res -> isJust (resource res)) $ map snd asts+              case mbRes of+                  Just (Result _ (Just (body, contentType))) -> do+                      modifyResponse $ setContentType (T.encodeUtf8 $ T.pack contentType)+                      writeBS body++                  _ -> pass
+ src/Data/Mole/Types.hs view
@@ -0,0 +1,162 @@+module Data.Mole.Types where++import           Control.Concurrent+import           Control.Concurrent.STM++import           Data.ByteString (ByteString)+import           Data.Map (Map)+import           Data.Set (Set)+import           Data.Time (UTCTime)++import qualified Network.Kraken as K++++-- | An 'AssetId' is an internal reference to an unprocessed asset. Source files+-- use those to express dependencies on other files. And the 'Config' object+-- contains definitions how to build those.+--+-- 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 }+    deriving (Ord, Eq)++instance Show AssetId where+    show = unAssetId+++newtype BuildId = BuildId { unBuildId :: Int }+    deriving (Ord, Eq, Show)++type ContentType = String+++data AssetState = Dirty | Building | Failed Error | Completed Result+    deriving (Eq, Show)++++data Config = Config+    { assetDefinitions :: Map AssetId AssetDefinition+      -- ^ All the assets we know how to build. This doesn't mean that they+      -- actually will be built. Only if they are referenced / required /+      -- reachable through one of the entry points.+      --+      -- This list is rarely created manually. Usually it's automatically+      -- generated by traversing a source directory and converting each+      -- file into an asset (depending on the file type).+      --+      -- Another option is to only define the entry points and maybe a few+      -- special assets and let auto-discovery do the rest.++    , autoDiscovery :: Handle -> AssetId -> IO (Maybe AssetDefinition)+     -- ^ If an asset is not defined statically, we attempt to do auto-discovery+     -- based on its 'AssetId'. The default implementation tries to locate the+     -- file below the base path where all the sources are. This works really+     -- well for binary files which need no processing (eg. images, font files)+     -- or files where we can infer the 'AssetDefinition' from its content type+     -- or file extension.++    , entryPoints :: [AssetId]+      -- ^ The entry points into the application. Usually this will include at+      -- least the index file (eg. index.html).+    }+++data AssetRuntimeState = AssetRuntimeState+    { arsState :: AssetState+    , arsSources :: Set FilePath+    , arsDependencySet :: Set AssetId+    } deriving (Show)+++type PublicIdentifier = String++data Result = Result+    { publicIdentifier :: PublicIdentifier+      -- ^ This is how other parts of the application can refer to the asset.+      -- This can be an absolute path or a full URL (for example if you're+      -- serving the assets from a CDN).++    , resource :: Maybe (ByteString, ContentType)+      -- ^ The content of the asset if built locally. For external assets (eg.+      -- jquery served from the google CDN) this is 'Nothing'.++    } deriving (Eq, Show)+++data Error+    = UndeclaredDependency AssetId+    | AssetNotFound AssetId+    | DependencyFailed+    deriving (Show, Eq)+++data Builder = Builder+    { assetSources :: Set FilePath+      -- An approximation of files which contributed to the asset. This is+      -- stored in the state and used to trigger rebuilds when the files on+      -- disk change.++    , assetDependencies :: Set AssetId+      -- ^ The dependencies of the asset which is currently being built. These+      -- dependencies are automatically built before the asset is packaged+      -- into its final result.++    , packageAsset :: Map AssetId PublicIdentifier -> Either Error Result+      -- ^ A function which takes the public identifiers for all dependencies+      -- and creates the final asset package.+    }+++data AssetDefinition = AssetDefinition+    { createBuilder :: Handle -> AssetId -> IO Builder+      -- ^ IO action which returns metadata about the asset and a function+      -- which assembles the asset into its final form.++    , transformPublicIdentifier :: PublicIdentifier -> PublicIdentifier+      -- ^ An optional transformer for the 'PublicIdentifier'. Use this if you+      -- want to serve the assets from a different path or domain. The default+      -- implementation simply prepends "/" to the pubId, therefore making the+      -- path absolute. If you want to serve the assets from a subdirectory,+      -- prepend for example "/assets/". If you use a CDN, make the pubId a+      -- full URL.++    , emitResult :: Handle -> AssetId -> Result -> IO ()+      -- ^ Action which is invoked every time an asset has completed building.+      -- This is useful if you want to store the asset in an output directory+      -- or maybe even directly upload to the server.+    }++++data State = State+    { dispatcherThreadId :: Maybe ThreadId+      -- ^ The thread which waits for assets to be marked as 'Dirty' and+      -- dispatches build jobs. Doing that in a single thread makes it easier+      -- to synchronize STM with IO.++    , stopFileWatcher :: IO ()+      -- ^ The file watcher is run in a separate thread. This is the action+      -- to stop it.++    , assets :: Map AssetId AssetRuntimeState+    }+++data Message = Message UTCTime AssetId String++data Handle = Handle+    { state :: TVar State+    , messages :: TQueue Message++    , emitStream :: TQueue (IO ())+      -- ^ This is used to serialize the emit actions. This is required because+      -- two different AssetIds may map to the same PublicIdentifier and+      -- Haskell throws an exception when writing to the same file concurrently.++    , krakenH :: !(Maybe K.Handle)+    --, messageThreadId :: ThreadId+    , lock :: !(TMVar ())+      -- ^ Generic lock for various things. Please make sure to not deadlock!+    }
+ src/Data/Mole/Watcher.hs view
@@ -0,0 +1,60 @@+{-# LANGUAGE OverloadedStrings #-}++module Data.Mole.Watcher+    ( attachFileWatcher+    , detachFileWatcher+    ) where+++import           Control.Concurrent.STM+import           Control.Concurrent+import           Control.Monad++import qualified Data.Map as M+import qualified Data.Set as S++import           Data.Maybe++import           System.FilePath+import           System.Directory+import           System.FSNotify hiding (defaultConfig)++import           Data.Mole.Types+import           Data.Mole.Core++++attachFileWatcher :: Handle -> IO ()+attachFileWatcher h = do+    cwd <- getCurrentDirectory+    void $ forkIO $ forever $ do+        withManager $ \mgr -> do+            stop <- watchTree mgr "." (const True) $ \ev -> do+                let p = eventPath ev+                rd <- reverseDependencies h cwd p+                forM_ rd $ \aId -> do+                    logMessage h aId $ "Rebuilding because " ++ p ++ " was modified"+                    markDirty h aId++            atomically $ modifyTVar (state h) (\s -> s { stopFileWatcher = stop })++            forever $ threadDelay maxBound+++detachFileWatcher :: Handle -> IO ()+detachFileWatcher h = do+    stop <- atomically $ do+        st <- readTVar (state h)+        modifyTVar (state h) (\s -> s { stopFileWatcher = return () })+        return $ stopFileWatcher st++    stop+++reverseDependencies :: Handle -> FilePath -> FilePath -> IO [AssetId]+reverseDependencies h cwd p = do+    s <- atomically $ readTVar (state h)+    return $ catMaybes $ (flip map) (M.toList $ assets s) $ \(aId, ars) ->+        if (S.member p $ S.map (\x -> cwd </> x) (arsSources ars))+            then Just aId+            else Nothing