diff --git a/mole.cabal b/mole.cabal --- a/mole.cabal +++ b/mole.cabal @@ -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 diff --git a/src/Data/Mole/Builder.hs b/src/Data/Mole/Builder.hs new file mode 100644 --- /dev/null +++ b/src/Data/Mole/Builder.hs @@ -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" diff --git a/src/Data/Mole/Builder/Binary.hs b/src/Data/Mole/Builder/Binary.hs new file mode 100644 --- /dev/null +++ b/src/Data/Mole/Builder/Binary.hs @@ -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)) + } diff --git a/src/Data/Mole/Builder/External.hs b/src/Data/Mole/Builder/External.hs new file mode 100644 --- /dev/null +++ b/src/Data/Mole/Builder/External.hs @@ -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 + } diff --git a/src/Data/Mole/Builder/Html.hs b/src/Data/Mole/Builder/Html.hs new file mode 100644 --- /dev/null +++ b/src/Data/Mole/Builder/Html.hs @@ -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) diff --git a/src/Data/Mole/Builder/Image.hs b/src/Data/Mole/Builder/Image.hs new file mode 100644 --- /dev/null +++ b/src/Data/Mole/Builder/Image.hs @@ -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) diff --git a/src/Data/Mole/Builder/Internal/Fingerprint.hs b/src/Data/Mole/Builder/Internal/Fingerprint.hs new file mode 100644 --- /dev/null +++ b/src/Data/Mole/Builder/Internal/Fingerprint.hs @@ -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 diff --git a/src/Data/Mole/Builder/Internal/Template.hs b/src/Data/Mole/Builder/Internal/Template.hs new file mode 100644 --- /dev/null +++ b/src/Data/Mole/Builder/Internal/Template.hs @@ -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 diff --git a/src/Data/Mole/Builder/JavaScript.hs b/src/Data/Mole/Builder/JavaScript.hs new file mode 100644 --- /dev/null +++ b/src/Data/Mole/Builder/JavaScript.hs @@ -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") + } diff --git a/src/Data/Mole/Builder/Stylesheet.hs b/src/Data/Mole/Builder/Stylesheet.hs new file mode 100644 --- /dev/null +++ b/src/Data/Mole/Builder/Stylesheet.hs @@ -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") diff --git a/src/Data/Mole/Core.hs b/src/Data/Mole/Core.hs new file mode 100644 --- /dev/null +++ b/src/Data/Mole/Core.hs @@ -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 diff --git a/src/Data/Mole/Server.hs b/src/Data/Mole/Server.hs new file mode 100644 --- /dev/null +++ b/src/Data/Mole/Server.hs @@ -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 diff --git a/src/Data/Mole/Types.hs b/src/Data/Mole/Types.hs new file mode 100644 --- /dev/null +++ b/src/Data/Mole/Types.hs @@ -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! + } diff --git a/src/Data/Mole/Watcher.hs b/src/Data/Mole/Watcher.hs new file mode 100644 --- /dev/null +++ b/src/Data/Mole/Watcher.hs @@ -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