diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2015 Tomas Carnecky + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be included +in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/mole.cabal b/mole.cabal new file mode 100644 --- /dev/null +++ b/mole.cabal @@ -0,0 +1,83 @@ +name: mole +version: 0.0.1 + +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 + + +source-repository head + type: git + location: git://github.com/wereHamster/mole.git + + +executable mole + hs-source-dirs: src + default-language: Haskell2010 + + ghc-options: -Wall -threaded -O2 -rtsopts + + main-is: Main.hs + + build-depends: + base >=4.6 && <4.9 + , containers + , bytestring + , base64-bytestring + , tagsoup + , stm + , cryptohash + , filepath + , filemanip + , fsnotify + , directory + , system-filepath + , snap + , snap-server + , text + , transformers + , process + , attoparsec + , network-uri + , optparse-applicative + , time + , mtl + , kraken + , unix + + +test-suite spec + hs-source-dirs: src test + default-language: Haskell2010 + + main-is: Test.hs + type: exitcode-stdio-1.0 + + build-depends: + base <4.9 + , hspec + , smallcheck + , hspec-smallcheck + , vector + , text + , unordered-containers + , time + , kraken + , attoparsec + , stm + , bytestring + , containers diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 --- /dev/null +++ b/src/Main.hs @@ -0,0 +1,210 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Main where + +import Control.Concurrent.STM +import Control.Monad +import Control.Monad.Reader +import Control.Applicative + +import Data.Map (Map) +import qualified Data.Map as M + +import qualified Data.Set as S + +import qualified Data.ByteString as BS + +import qualified Data.Text as T + +import Data.Monoid +import Data.List hiding (stripPrefix) + +import Network.URI + +import System.FilePath +import System.FilePath.Find as FPF +import System.Directory + +import Data.Mole.Types +import Data.Mole.Core +import Data.Mole.Server +import Data.Mole.Watcher +import Data.Mole.Builder +import Data.Mole.Builder.External + +import Options.Applicative +import Options.Applicative.Types + + + +main :: IO () +main = do + opt <- execParser (parseOptions `withInfo` "mole") + run opt (optCommand opt) + + +data Options = Options + { optCommand :: Command + + , optPaths :: [FilePath] + -- ^ The paths where auto-discovery looks for assets. + + , optAssets :: [(AssetId,AssetDefinition)] + -- ^ Additional assets that are specified on the commandline. + } + +data Command + = Version + | Build !FilePath + | Serve + + +run :: Options -> Command -> IO () +run _ Version = putStrLn "HEAD" + +run opt (Build outputDir) = do + config <- mkConfig opt outputDir + h <- newHandle config + + forM_ (entryPoints config) $ \aId -> + markDirty h aId + + _ <- require h (S.fromList $ entryPoints config) + atomically $ do + e <- isEmptyTQueue (messages h) + unless e retry + + atomically $ do + e <- isEmptyTQueue (emitStream h) + unless e retry + +run opt Serve = do + config <- mkConfig opt "" + h <- newHandle config + + attachFileWatcher h + + -- Mark all entry points as dirty to have the assets ready as soon as + -- possible, hopefully even before the user opens the web server. + forM_ (entryPoints config) $ \aId -> + markDirty h aId + + serveFiles h + + +collectAssetDefinitions :: FilePath -> FilePath -> IO (Map AssetId AssetDefinition) +collectAssetDefinitions outputDir basePath = do + FPF.fold (pure True) f M.empty basePath + where + f m fi = if takeExtension p == ".html" + then M.insert + (AssetId $ drop (length basePath + 1) $ p) + (AssetDefinition (builderForFile basePath p) transformPublicIdentifierDef (emitResultDef outputDir)) + m + else m + where p = infoPath fi + + +transformPublicIdentifierDef :: PublicIdentifier -> PublicIdentifier +transformPublicIdentifierDef ('/':pubId) = '/' : pubId +transformPublicIdentifierDef pubId = '/' : pubId + + +defAutoDiscovery :: Options -> FilePath -> Handle -> AssetId -> IO (Maybe AssetDefinition) +defAutoDiscovery opt outputDir h (AssetId aId) + | aId == "" = do + return $ Just $ AssetDefinition (externalBuilder aId) id (emitResultDef outputDir) + | isURI aId = do + return $ Just $ AssetDefinition (externalBuilder 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) + | otherwise = do + res <- concat <$> mapM (\basePath -> do + paths <- FPF.find (pure True) f basePath + return $ zip (repeat basePath) paths + ) (optPaths opt) + case sortOn (length . snd) res of + (basePath, x):_ -> do + -- logMessage h (AssetId aId) $ "Found asset at " ++ x + return $ Just $ AssetDefinition (builderForFile basePath x) + transformPublicIdentifierDef (emitResultDef outputDir) + _ -> return Nothing + + + where + f = do + p <- filePath + t <- fileType + return $ t == RegularFile && isSuffixOf aId p + +emitResultDef :: FilePath -> Handle -> AssetId -> Result -> IO () +emitResultDef dist _ _ (Result pubId mbRes) = do + case mbRes of + Nothing -> return () + Just (body, _) -> when (dist /= "") $ do + -- putStrLn $ "emit " ++ pubId + createDirectoryIfMissing True $ dist `joinDrive` (takeDirectory pubId) + BS.writeFile (dist `joinDrive` pubId) body + +mkConfig :: Options -> FilePath -> IO Config +mkConfig opt outputDir = do + otherAssets <- mconcat <$> mapM (collectAssetDefinitions outputDir) (optPaths opt) + + let allAssets = M.fromList (optAssets opt) <> otherAssets + let allEntryPoints = filter (\(AssetId a) -> T.isSuffixOf ".html" (T.pack a)) $ M.keys allAssets + -- print $ M.keys allAssets + + return $ Config allAssets (defAutoDiscovery opt outputDir) allEntryPoints + + + + +parseOptions :: Parser Options +parseOptions = Options <$> parseCommand <*> parsePaths <*> many parseAsset + +parseCommand :: Parser Command +parseCommand = subparser $ mconcat + [ command "version" + (parseVersion `withInfo` "Print the version and exit") + , command "build" + (parseBuild `withInfo` "Build the website") + , command "serve" + (parseServe `withInfo` "Serve the website") + ] + +parseVersion :: Parser Command +parseVersion = pure Version + +parseBuild :: Parser Command +parseBuild = Build + <$> strArgument (metavar "OUTPUT-DIRECTORY" <> help "Where to write the files to.") + +parseServe :: Parser Command +parseServe = pure Serve + +assetRead :: ReadM (AssetId, AssetDefinition) +assetRead = ReadM $ do + v <- ask + case map T.unpack $ T.splitOn "=" $ T.pack v of + [aId, p] -> return $ (AssetId aId, AssetDefinition (externalBuilder p) id (\_ _ _ -> return ())) + _ -> fail "ASSET=DEFINITION" + +parseAsset :: Parser (AssetId, AssetDefinition) +parseAsset = option assetRead + ( long "asset" <> short 'a' <> metavar "ASSET=DEFINITION" ) + + +parsePaths :: Parser [FilePath] +parsePaths = option pathRead + ( 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 + (x:xs) -> return $ x:xs + _ -> fail "SEARCH:PATH:DIRS:..." + + +withInfo :: Parser a -> String -> ParserInfo a +withInfo opts desc = info (helper <*> opts) $ progDesc desc diff --git a/test/Test.hs b/test/Test.hs new file mode 100644 --- /dev/null +++ b/test/Test.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Main where + + +import Control.Applicative + +import Test.Hspec +import Test.SmallCheck +import Test.SmallCheck.Series +import Test.Hspec.SmallCheck + +import Data.Monoid ((<>)) +import Data.Function +import Data.List +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HMS +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time +import Data.Time.Clock.POSIX + + +import Data.Mole.Builder.Internal.Template + + + +main :: IO () +main = do + hspec $ spec + + +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] + it "should strip whitespace around a var" $ do + template "<* \nvar \t *>" `shouldBe` + Template [ Var "var" ] + it "should parse a string with a var in it" $ do + template "some <* var *> template" `shouldBe` + Template [ Lit "some ", Var "var", Lit " template" ] + it "should parse two directly adjacent vars" $ do + template "<* v1 *><* v2 *>" `shouldBe` + Template [ Var "v1", Var "v2" ] + it "should parse two adjacent vars with a whitespace in between" $ do + template "<* v1 *> <* v2 *>" `shouldBe` + Template [ Var "v1", Lit " ", Var "v2" ] + it "should ignore a false start of a var" $ do + template "
link
" `shouldBe` + Template [ Lit "
link
" ] + it "should allow literals between two false starts" $ do + template "
<* var *>
" `shouldBe` + Template [ Lit "
", Var "var", Lit "
" ]