packages feed

sprinkles (empty) → 0.3.5.0

raw patch · 47 files changed

+5088/−0 lines, 47 filesdep +Cabaldep +Globdep +HDBCsetup-changed

Dependencies added: Cabal, Glob, HDBC, HDBC-mysql, HDBC-postgresql, HDBC-sqlite3, HTTP, aeson, aeson-pretty, array, base, bytestring, case-insensitive, cereal, classy-prelude, containers, curl, data-default, directory, filepath, ginger, hashable, heredoc, hsyslog, http-types, memcached-binary, mime-types, mtl, network-uri, pandoc, pandoc-creole, pandoc-types, parsec, process, random-shuffle, regex-base, regex-pcre, safe, scientific, sprinkles, system-locale, tasty, tasty-hunit, tasty-quickcheck, template-haskell, temporary, text, time, transformers, unix-compat, unordered-containers, utf8-string, vector, wai, wai-extra, wai-handler-fastcgi, warp, yaml

Files

+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Tobias Dammers (c) 2016++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Author name here nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ app/Main.hs view
@@ -0,0 +1,122 @@+{-#LANGUAGE NoImplicitPrelude #-}+{-#LANGUAGE OverloadedStrings #-}+{-#LANGUAGE TemplateHaskell #-}+{-#LANGUAGE ScopedTypeVariables #-}++-- | CLI program that drives a Sprinkles instance.+module Main where++import ClassyPrelude hiding ( (<|>), try )+import Web.Sprinkles+import Web.Sprinkles.Exceptions+import Text.Read (read, readMaybe)+import Data.Default (def)+import Text.Parsec+import Data.EmbedVersion++data CliOptions =+    ServeProject ServerConfig |+    DumpVersion++parseArgs :: [Text] -> IO CliOptions+parseArgs argv = do+    let result = runParser argsP () "command line arguments" argv+    either+        (fail . show)+        return+        result++type ArgsP = Parsec [Text] ()++data ArgSpec a = Flag Text a+               | Optional Text (Maybe Text -> Maybe a)+               | Required Text (Text -> Maybe a)+               | Bare (Text -> Maybe a)++argsP :: ArgsP CliOptions+argsP = versionP <|> serveArgsP++versionP :: ArgsP CliOptions+versionP =+    (try (tExactly "-version") <|>+     try (tExactly "--version") <|>+     try (tExactly "-v")) >> return DumpVersion++serveArgsP :: ArgsP CliOptions+serveArgsP = do+    pipeline <- Text.Parsec.many $ choice (map (Text.Parsec.try . argP) argSpecs)+    return . ServeProject $ foldr ($) def pipeline++tSatisfy :: (Show t, Stream s m t) => (t -> Bool) -> ParsecT s u m t+tSatisfy cond = do+    actual <- anyToken+    if cond actual+        then return actual+        else fail $ "unexpected " ++ show actual++tExactly :: (Show t, Stream s m t, Eq t) => t -> ParsecT s u m t+tExactly expected = tSatisfy (== expected)++isFlag :: Text -> Bool+isFlag = ("-" `isPrefixOf`)++isNotFlag :: Text -> Bool+isNotFlag = not . isFlag++argP :: ArgSpec a -> ArgsP a+argP (Flag str x) = do+    tExactly ("-" <> str)+    return x+argP (Optional str f) = do+    tExactly ("-" <> str)+    paramMay <- optionMaybe (tSatisfy isNotFlag)+    maybe+        (fail "invalid parameter")+        return+        (f paramMay)+argP (Required str f) = do+    tExactly ("-" <> str)+    param <- tSatisfy isNotFlag+    maybe+        (fail "invalid parameter")+        return+        (f param)+argP (Bare f) =+    (f <$> tSatisfy isNotFlag) >>= maybe (fail "invalid bare argument") return++argSpecs :: [ArgSpec (ServerConfig -> ServerConfig)]+argSpecs =+    [ Optional+        "warp"+        (maybe+            (Just $ \config -> config { scDriver = WarpDriver Nothing })+            (\str -> do+                port <- readMaybe . unpack $ str+                return $ \config -> config { scDriver = WarpDriver (Just port) })+        )+    , Bare (\str -> do+                port <- readMaybe . unpack $ str+                return $ \config -> config { scDriver = WarpDriver (Just port) })+    , Flag "cgi" (\config -> config { scDriver = CGIDriver })+    , Flag "scgi" (\config -> config { scDriver = SCGIDriver })+    , Flag "fcgi" (\config -> config { scDriver = FastCGIDriver })+    ]++sprinklesVersion = $(embedPackageVersionStr "sprinkles.cabal")++main :: IO ()+main = runMain `catch` handleUncaughtExceptions++runMain :: IO ()+runMain = do+    args <- getArgs+    opts <- parseArgs args+    case opts of+        ServeProject sconfigA -> do+            sconfigF <- loadServerConfig "."+            let sconfig = sconfigF `mappend` sconfigA++            project <- loadProject sconfig "."+            serveProject sconfig project+        DumpVersion -> do+            putStrLn sprinklesVersion
+ sprinkles.cabal view
@@ -0,0 +1,149 @@+name:                sprinkles+version:             0.3.5.0+synopsis:            JSON API to HTML website wrapper+description:         Please see README.md+homepage:            https://bitbucket.org/tdammers/sprinkles+license:             BSD3+license-file:        LICENSE+author:              Author name here+maintainer:          tdammers@gmail.com+copyright:           2016 Tobias Dammers+category:            Web+build-type:          Simple+-- extra-source-files:+cabal-version:       >=1.10++library+  hs-source-dirs: src+  exposed-modules: Web.Sprinkles+                 , Web.Sprinkles.Logger+                 , Web.Sprinkles.Exceptions+                 , Web.Sprinkles.Databases+                 , Web.Sprinkles.Cache+                 , Web.Sprinkles.Cache.Filesystem+                 , Web.Sprinkles.Cache.Memory+                 , Web.Sprinkles.Cache.Memcached+                 , Web.Sprinkles.Pattern+                 , Web.Sprinkles.Replacement+                 , Web.Sprinkles.Backends+                 , Web.Sprinkles.Backends.Loader+                 , Web.Sprinkles.Backends.Spec+                 , Web.Sprinkles.Backends.Data+                 , Web.Sprinkles.Backends.Parsers+                 , Web.Sprinkles.Backends.Loader.SqlLoader+                 , Web.Sprinkles.Backends.Loader.FileLoader+                 , Web.Sprinkles.Backends.Loader.Type+                 , Web.Sprinkles.Backends.Loader.HttpLoader+                 , Web.Sprinkles.Backends.Loader.SubprocessLoader+                 , Web.Sprinkles.Backends.Loader.RequestBodyLoader+                 , Web.Sprinkles.Backends.Loader.LiteralLoader+                 , Web.Sprinkles.Handlers+                 , Web.Sprinkles.Handlers.Common+                 , Web.Sprinkles.Handlers.Respond+                 , Web.Sprinkles.Handlers.Static+                 , Web.Sprinkles.Handlers.Redirect+                 , Web.Sprinkles.Handlers.JSON+                 , Web.Sprinkles.Handlers.Template+                 , Web.Sprinkles.MatchedText+                 , Web.Sprinkles.PandocGVal+                 , Web.Sprinkles.Rule+                 , Web.Sprinkles.ProjectConfig+                 , Web.Sprinkles.ServerConfig+                 , Web.Sprinkles.Project+                 , Web.Sprinkles.Serve+                 , Control.MaybeEitherMonad+                 , Data.EmbedVersion+                 , Data.AList+                 , Data.Walk+  build-depends: base >= 4.7 && < 5+               , Cabal+               , Glob+               , HDBC+               , HDBC-postgresql+               , HDBC-sqlite3+               , HDBC-mysql+               , HTTP+               , aeson+               , aeson-pretty+               , array+               , bytestring+               , case-insensitive+               , cereal+               , classy-prelude+               , containers+               , curl+               , data-default+               , directory+               , filepath+               , ginger >=0.3.8.0 && <0.4+               , hashable+               , hsyslog+               , http-types+               , memcached-binary+               , mime-types+               , mtl+               , network-uri+               , pandoc+               , pandoc-creole+               , pandoc-types+               , parsec+               , process+               , random-shuffle+               , regex-base+               , regex-pcre+               , safe+               , scientific+               , system-locale+               , template-haskell+               , text+               , time+               , transformers+               , unix-compat+               , unordered-containers+               , utf8-string+               , vector+               , wai+               , wai-extra+               , wai-handler-fastcgi+               , warp+               , yaml+  default-language:    Haskell2010++executable sprinkles+  hs-source-dirs: app+  main-is: Main.hs+  ghc-options: -threaded -rtsopts -with-rtsopts=-N+  build-depends: base+               , sprinkles+               , classy-prelude+               , data-default+               , safe+               , parsec+  default-language: Haskell2010++test-suite sprinkles-test+  type:                exitcode-stdio-1.0+  hs-source-dirs:      test+  main-is:             Spec.hs+  other-modules: Web.Sprinkles.PatternTest+               , Web.Sprinkles.ApplicationTest+  build-depends: base+               , sprinkles+               , classy-prelude+               , data-default+               , directory+               , filepath+               , heredoc+               , regex-base+               , regex-pcre+               , tasty+               , tasty-hunit+               , tasty-quickcheck+               , temporary+               , wai-extra+  ghc-options:         -threaded -rtsopts -with-rtsopts=-N+  default-language:    Haskell2010++source-repository head+  type:     git+  location: https://bitbucket.org/tdammers/sprinkles
+ src/Control/MaybeEitherMonad.hs view
@@ -0,0 +1,51 @@+-- | A collection of utility functions to mediate between 'Maybe', 'Either',+-- other 'Monad's, and exceptions.+module Control.MaybeEitherMonad+where++import Control.Exception+import Data.Maybe (fromMaybe)++-- | Return the 'Just' value, or fail on 'Nothing'+maybeFail :: Monad m => Maybe a -> m a+maybeFail = maybe (fail "Nothing") return++-- | Return the 'Right' value, or fail with the 'Left' error message.+eitherFailS :: Monad m => Either String a -> m a+eitherFailS = either fail return++-- | Return the 'Right' value, or fail with the 'Left' error value.+eitherFail :: (Show s, Monad m) => Either s a -> m a+eitherFail = either (fail . show) return++-- | Thrown when 'maybeFail' runs into a 'Nothing'+data NothingException = NothingException+    deriving (Show)++instance Exception NothingException where++-- | Thrown when 'eitherFail' or 'eitherFailS' runs into a 'Left'+data LeftException = LeftException String+    deriving (Show)++instance Exception LeftException where++-- | Get 'Just' the value, or throw a 'NothingException'+maybeThrow :: Maybe a -> a+maybeThrow = fromMaybe (throw NothingException)++-- | Get the 'Right' value, or throw a 'LeftException'+eitherThrowS :: Either String a -> a+eitherThrowS = either (throw . LeftException) id++-- | Get the 'Right' value, or throw a 'LeftException'+eitherThrow :: Exception err => Either err a -> a+eitherThrow = either throw id++eitherThrowWith :: Exception err => (x -> err) -> Either x a -> a+eitherThrowWith f = either (throw . f) id++-- | @optionally f v@ executes the @f@ action on 'Just' the value of @v@, or+-- does nothing if @v@ is 'Nothing'.+optionally :: Monad m => (a -> m ()) -> Maybe a -> m ()+optionally = maybe (return ())
+ src/Data/AList.hs view
@@ -0,0 +1,44 @@+{-#LANGUAGE NoImplicitPrelude #-}+{-#LANGUAGE GeneralizedNewtypeDeriving #-}+{-#LANGUAGE FlexibleInstances #-}+{-#LANGUAGE MultiParamTypeClasses #-}+{-#LANGUAGE DeriveFunctor #-}+module Data.AList+( AList+, toList+, fromList+, empty+, singleton+)+where++import ClassyPrelude hiding (fromList, toList, singleton, empty)+import Data.Aeson (ToJSON (..), FromJSON (..), Value (..))+import qualified Data.HashMap.Strict as HashMap+import Data.Monoid+import Data.Text (Text)+import qualified Data.Vector as Vector+import Control.Monad (forM)++newtype AList k v = AList { toList :: [(k, v)] }+    deriving (Functor, Monoid, Show, Read, Eq, Semigroup)++fromList :: [(k, v)] -> AList k v+fromList = AList++instance FromJSON a => FromJSON (AList Text a) where+    parseJSON (Array items) =+        mconcat <$> forM (Vector.toList items) parseJSON+    parseJSON v@(Object obj) =+        AList . HashMap.toList <$> parseJSON v+    parseJSON x = fail "Invalid JSON value for AList"++instance ToJSON a => ToJSON (AList Text a) where+    toJSON (AList items) =+        toJSON [ HashMap.singleton k v | (k, v) <- items ]++empty :: AList k v+empty = AList []++singleton :: k -> v -> AList k v+singleton k v = AList [(k, v)]
+ src/Data/EmbedVersion.hs view
@@ -0,0 +1,82 @@+{-#LANGUAGE OverloadedStrings #-}+{-#LANGUAGE ScopedTypeVariables #-}+module Data.EmbedVersion+where++import Distribution.Version+import Distribution.Verbosity+import Distribution.Package+import Distribution.PackageDescription+import Distribution.PackageDescription.Parse+import Language.Haskell.TH+import Language.Haskell.TH.Syntax+import Data.List (intercalate, isPrefixOf)+import System.Process+import System.Exit+import qualified Data.Text as Text+import Data.Text (Text)+import Data.Char (isSpace)+import Control.Exception+++getPackageVersion :: FilePath -> IO Version+getPackageVersion cabalFileName = do+    gpd <- readPackageDescription silent cabalFileName+    return . pkgVersion . package. packageDescription $ gpd++getPackageVersionStr :: FilePath -> IO String+getPackageVersionStr = fmap formatPackageVersion . getPackageVersion++runGit :: [String] -> IO String+runGit args = do+    (exitCode, stdout, stderr) <- readProcessWithExitCode "git" args ""+    case exitCode of+        ExitSuccess -> return stdout+        e -> fail $ "git:" ++ stderr++data GitVersion = GitTag String String+                | GitCommit String+                | Unversioned++getGitVersionStr :: IO GitVersion+getGitVersionStr = do+    currentCommit <- runGit ["log", "-1", "--pretty=tformat:%H %d"]+    let (commitHash, refInfo) = break isSpace currentCommit+    let refStrs = map Text.strip+                . Text.splitOn ","+                . Text.dropAround (`elem` ("()" :: [Char]))+                . Text.strip+                . Text.pack+                $ refInfo+    return $ case filter ("tag: " `Text.isPrefixOf`) refStrs of+            (tagRef:_) -> GitTag (Text.unpack $ Text.drop 5 tagRef) commitHash+            [] -> GitCommit commitHash++haveGitModifications :: IO Bool+haveGitModifications = do+    output <- runGit ["status", "--porcelain"]+    let outLines = filter (not . null) . lines $ output+    return . not . null $ outLines++formatPackageVersion :: Version -> String+formatPackageVersion =+    intercalate "." . map show . versionBranch++embedPackageVersionStr :: FilePath -> Q Exp+embedPackageVersionStr fp = do+    gitVersion <- runIO $ getGitVersionStr `catch` \(err :: IOError) -> return Unversioned+    cabalVersion <- runIO (getPackageVersionStr fp)++    let version = case gitVersion of+            GitCommit c -> cabalVersion ++ "+git-" ++ c+            GitTag t c ->+                if (cabalVersion ++ "-") `isPrefixOf` t || cabalVersion == t+                    then t+                    else cabalVersion ++ " (" ++ t ++ ")"+            Unversioned -> cabalVersion+    modificationsStr <- runIO $ do+        modifications <- haveGitModifications `catch` \(err :: IOError) -> return False+        if modifications+            then return "+modifications"+            else return ""+    stringE $ version ++ modificationsStr
+ src/Data/Walk.hs view
@@ -0,0 +1,35 @@+{-#LANGUAGE MultiParamTypeClasses #-}+{-#LANGUAGE FlexibleInstances #-}++module Data.Walk+( Walk (..)+)+where++import qualified Data.Aeson as JSON+import Data.Text (Text)+import qualified Data.Text as Text+import Data.Vector (Vector)+import qualified Data.Vector as Vector+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as HashMap++class Walk c e where+    walk :: (e -> e) -> (c -> c)++instance Walk JSON.Value Text where+    walk = jsonTextWalk++jsonTextWalk :: (Text -> Text) -> (JSON.Value -> JSON.Value)+jsonTextWalk f (JSON.String t) = JSON.String (f t)+jsonTextWalk f (JSON.Array v) = JSON.Array (fmap (walk f) v)+jsonTextWalk f (JSON.Object m) =+    JSON.Object . HashMap.fromList $+        [ (f k, walk f v) | (k, v) <- HashMap.toList m ]+jsonTextWalk _ x = x++instance Walk [a] a where+    walk = map++instance Walk (Maybe a) a where+    walk = fmap
+ src/Web/Sprinkles.hs view
@@ -0,0 +1,15 @@+{-#LANGUAGE NoImplicitPrelude #-}+module Web.Sprinkles+( loadProject+, serveProject+, ServerConfig (..)+, loadServerConfig+, ServerDriver (..)+)+where++import ClassyPrelude+import Web.Sprinkles.Project+import Web.Sprinkles.ServerConfig+import Web.Sprinkles.Serve+
+ src/Web/Sprinkles/Backends.hs view
@@ -0,0 +1,126 @@+{-#LANGUAGE NoImplicitPrelude #-}+{-#LANGUAGE OverloadedStrings #-}+{-#LANGUAGE TypeFamilies #-}+{-#LANGUAGE MultiParamTypeClasses #-}+{-#LANGUAGE FlexibleInstances #-}+{-#LANGUAGE FlexibleContexts #-}+{-#LANGUAGE LambdaCase #-}++-- | Main Backend module.+module Web.Sprinkles.Backends+(+-- * Defining backends+  BackendSpec+, parseBackendURI+-- * Fetching backend data+, BackendData (..)+, BackendMeta (..)+, Items (..)+, loadBackendData+, RawBackendCache+, rawToLBS+, rawFromLBS+)+where++import ClassyPrelude+import System.Random.Shuffle (shuffleM)+import Web.Sprinkles.Cache+import qualified Data.Serialize as Cereal+import Control.MaybeEitherMonad (eitherFailS)+import Web.Sprinkles.Logger (LogLevel (..))+import Network.Mime (MimeType)++import Web.Sprinkles.Backends.Spec+        ( BackendSpec (..)+        , BackendType (..)+        , AscDesc (..)+        , FetchMode (..)+        , FetchOrder (..)+        , FetchOrderField (..)+        , parseBackendURI+        , CachePolicy (..)+        , cachePolicy+        )+import Web.Sprinkles.Backends.Parsers+        ( parseBackendData+        )+import Web.Sprinkles.Backends.Data+        ( BackendData (..)+        , BackendMeta (..)+        , BackendSource (..)+        , Items (..)+        , reduceItems+        , serializeBackendSource+        , deserializeBackendSource+        , rawFromLBS+        , rawToLBS+        )+import Web.Sprinkles.Backends.Loader+import Web.Sprinkles.Backends.Loader.Type (PostBodySource)++-- | Cache for raw backend data, stored as bytestrings.+type RawBackendCache = Cache ByteString ByteString++-- | Well-typed backend cache.+type BackendCache = Cache BackendSpec [BackendSource]++-- | Execute a backend query, with caching.+loadBackendData :: Monad m+                => (LogLevel -> Text -> IO ())+                -> PostBodySource+                -> RawBackendCache+                -> BackendSpec+                -> IO (Items (BackendData m h))+loadBackendData writeLog cache loadPost bspec =+    fmap (reduceItems (bsFetchMode bspec)) $+        fetchBackendData writeLog cache loadPost bspec >>=+        mapM parseBackendData >>=+        sorter+    where+        sorter :: [BackendData m h] -> IO [BackendData m h]+        sorter = fmap reverter . baseSorter+        reverter :: [a] -> [a]+        reverter = case fetchAscDesc (bsOrder bspec) of+            Ascending -> id+            Descending -> reverse+        baseSorter :: [BackendData m h] -> IO [BackendData m h]+        baseSorter = case fetchField (bsOrder bspec) of+            ArbitraryOrder -> return+            RandomOrder -> shuffleM+            OrderByName -> return . sortOn (bmName . bdMeta)+            OrderByMTime -> return . sortOn (bmMTime . bdMeta)++-- | What the type says: expose a raw backend cache (bytestrings) as a+-- well-typed backend cache.+wrapBackendCache :: RawBackendCache -> BackendCache+wrapBackendCache =+    transformCache+        Cereal.encode+        (eitherFailS . Cereal.decode)+        (fmap (Just . Cereal.encode) . mapM serializeBackendSource)+        (fmap Just . fmap (map deserializeBackendSource) . eitherFailS . Cereal.decode)++-- | Fetch raw backend data from a backend source, with caching.+fetchBackendData :: (LogLevel -> Text -> IO ()) -> PostBodySource -> RawBackendCache -> BackendSpec -> IO [BackendSource]+fetchBackendData writeLog loadPost rawCache spec =+    cacheWrap (fetchBackendData' writeLog loadPost) spec+    where+        cacheWrap = case cachePolicy spec of+            CacheForever -> cached cache+            NoCaching -> id+        cache :: BackendCache+        cache = wrapBackendCache rawCache++-- | Fetch raw backend data from a backend source, without caching.+fetchBackendData' :: (LogLevel -> Text -> IO ()) -> PostBodySource -> BackendSpec -> IO [BackendSource]+fetchBackendData'+        writeLog+        loadPost+        (BackendSpec backendType fetchMode fetchOrder mimeOverride) =+    map (overrideMime mimeOverride) <$> loader backendType writeLog loadPost fetchMode fetchOrder++overrideMime :: Maybe MimeType -> BackendSource -> BackendSource+overrideMime Nothing s = s+overrideMime (Just m) s =+    s { bsMeta = (bsMeta s) { bmMimeType = m } }
+ src/Web/Sprinkles/Backends/Data.hs view
@@ -0,0 +1,230 @@+{-#LANGUAGE NoImplicitPrelude #-}+{-#LANGUAGE OverloadedStrings #-}+{-#LANGUAGE TypeFamilies #-}+{-#LANGUAGE MultiParamTypeClasses #-}+{-#LANGUAGE FlexibleInstances #-}+{-#LANGUAGE FlexibleContexts #-}+{-#LANGUAGE LambdaCase #-}+{-#LANGUAGE DeriveGeneric #-}++-- | Types for and operations on backend data.+module Web.Sprinkles.Backends.Data+( BackendData (..)+, BackendMeta (..)+, BackendSource (..)+, RawBytes (..)+, toBackendData+, Items (..)+, reduceItems+, addBackendDataChildren+, rawToLBS+, rawFromLBS+, serializeBackendSource+, deserializeBackendSource+)+where++import ClassyPrelude+import Text.Ginger (ToGVal (..), GVal, Run (..), dict, (~>))+import qualified Text.Ginger as Ginger+import Data.Aeson as JSON+import Data.Aeson.TH as JSON+import Data.Yaml as YAML+import qualified Data.Serialize as Cereal+import Data.Serialize (Serialize)+import Foreign.C.Types (CTime (..))+import Network.Mime (MimeType)+import Data.Default (Default (..))+import Data.Time.Clock.POSIX (POSIXTime, posixSecondsToUTCTime)+import Data.Time (UTCTime, LocalTime, utc, utcToLocalTime)+import Data.Scientific (Scientific)++import Web.Sprinkles.Backends.Spec++-- | Extract raw integer value from a 'CTime'+unCTime :: CTime -> Int+unCTime (CTime i) = fromIntegral i++-- | The shapes of data that can be returned from a backend query.+data Items a = NotFound -- ^ Nothing was found+             | SingleItem a -- ^ A single item was requested, and this is it+             | MultiItem [a] -- ^ Multiple items were requested, here they are++-- | Transform a raw list of results into an 'Items' value. This allows us+-- later to distinguish between Nothing Found vs. Empty List, and between+-- Single Item Requested And Found vs. Many Items Requested, One Found. This+-- is needed such that when a single item is requested, it gets converted to+-- 'GVal' and JSON as a scalar, while when we request many items and receive+-- one, it becomes a singleton list.+reduceItems :: FetchMode -> [a] -> Items a+reduceItems FetchOne [] = NotFound+reduceItems FetchOne (x:_) = SingleItem x+reduceItems FetchAll xs = MultiItem xs+reduceItems (FetchN n) xs = MultiItem $ take n xs++instance ToGVal m a => ToGVal m (Items a) where+    toGVal NotFound = def+    toGVal (SingleItem x) = toGVal x+    toGVal (MultiItem xs) = toGVal xs++instance ToJSON a => ToJSON (Items a) where+    toJSON NotFound = Null+    toJSON (SingleItem x) = toJSON x+    toJSON (MultiItem xs) = toJSON xs++data RawBytes =+    RawBytes+        { rbLength :: IO Integer+        , rbGetRange :: Integer -> Integer -> IO LByteString+        }++rawFromLBS :: LByteString -> RawBytes+rawFromLBS b =+    RawBytes+        { rbLength = return . fromIntegral $ length b+        , rbGetRange = \start len ->+            return+                . take (fromIntegral len)+                . drop (fromIntegral start)+                $ b+        }++rawToLBS :: RawBytes -> IO LByteString+rawToLBS r = do+    len <- rbLength r+    rbGetRange r 0 len++-- | A parsed record from a query result.+data BackendData m h =+    BackendData+        { bdJSON :: JSON.Value -- ^ Result body as JSON+        , bdGVal :: GVal (Run m h) -- ^ Result body as GVal+        , bdRaw :: RawBytes -- ^ Raw result body source+        , bdMeta :: BackendMeta -- ^ Meta-information+        , bdChildren :: HashMap Text (BackendData m h) -- ^ Child documents+        }++-- | A raw (unparsed) record from a query result.+data BackendSource =+    BackendSource+        { bsMeta :: BackendMeta+        , bsSource :: RawBytes+        }+        deriving (Generic)++data SerializableBackendSource =+    SerializableBackendSource+        { sbsMeta :: BackendMeta+        , sbsSource :: LByteString+        }+        deriving (Generic)++instance Serialize SerializableBackendSource where++serializeBackendSource :: BackendSource -> IO SerializableBackendSource+serializeBackendSource bs = do+    srcBytes <- rawToLBS . bsSource $ bs+    return $ SerializableBackendSource (bsMeta bs) srcBytes++deserializeBackendSource :: SerializableBackendSource -> BackendSource+deserializeBackendSource sbs =+    BackendSource (sbsMeta sbs) (rawFromLBS $ sbsSource sbs)++-- | Wrap a parsed backend value in a 'BackendData' structure. The original+-- raw 'BackendSource' value is needed alongside the parsed value, because the+-- resulting structure contains both the 'BackendMeta' and the raw (unparsed)+-- data from it.+toBackendData :: (ToJSON a, ToGVal (Run m h) a) => BackendSource -> a -> BackendData m h+toBackendData src val =+    BackendData+        { bdJSON = toJSON val+        , bdGVal = toGVal val+        , bdRaw = bsSource src+        , bdMeta = bsMeta src+        , bdChildren = mapFromList []+        }++addBackendDataChildren :: HashMap Text (BackendData m h)+                       -> BackendData m h+                       -> BackendData m h+addBackendDataChildren children bd =+    bd { bdChildren = children <> bdChildren bd }++instance ToJSON (BackendData m h) where+    toJSON = bdJSON++instance ToGVal (Run m h) (BackendData m h) where+    toGVal bd =+        let baseVal = bdGVal bd+            baseLookup = fromMaybe (const def) $ Ginger.asLookup baseVal+            baseDictItems = Ginger.asDictItems baseVal+            children = bdChildren bd+            childrenG = toGVal children+        in baseVal+            { Ginger.asLookup = Just $ \case+                "props" -> return . toGVal . bdMeta $ bd+                "children" -> return childrenG+                k -> baseLookup k+            , Ginger.asDictItems =+                (("props" ~> bdMeta bd):) .+                (("children", childrenG):) <$> baseDictItems+            }++-- | Metadata for a backend query result.+data BackendMeta =+    BackendMeta+        { bmMimeType :: MimeType+        , bmMTime :: Maybe POSIXTime -- ^ Last modification time, if available+        , bmName :: Text -- ^ Human-friendly name+        , bmPath :: Text -- ^ Path, according to the semantics of the backend (file path or URI)+        , bmSize :: Maybe Integer -- ^ Size of the raw source, in bytes, if available+        }+        deriving (Show, Generic)++instance Serialize BackendMeta where+    put bm = do+        Cereal.put $ bmMimeType bm+        Cereal.put . fmap fromEnum $ bmMTime bm+        Cereal.put . encodeUtf8 $ bmName bm+        Cereal.put . encodeUtf8 $ bmPath bm+        Cereal.put $ bmSize bm+    get =+        BackendMeta <$> Cereal.get+                    <*> (fmap toEnum <$> Cereal.get)+                    <*> (decodeUtf8 <$> Cereal.get)+                    <*> (decodeUtf8 <$> Cereal.get)+                    <*> Cereal.get++mtimeFlavors :: BackendMeta -> (Maybe POSIXTime, Maybe Scientific, Maybe LocalTime)+mtimeFlavors bm =+    let mtime = bmMTime bm+    in ( mtime+       , realToFrac <$> mtime :: Maybe Scientific+       , utcToLocalTime utc . posixSecondsToUTCTime <$> mtime+       )++instance ToJSON BackendMeta where+    toJSON bm =+        let (mtime, mtimeSci, mtimeUTC) = mtimeFlavors bm+        in JSON.object+            [ "mimeType" .= decodeUtf8 (bmMimeType bm)+            , "mtime" .= mtimeSci+            , "mtimeUTC" .= mtimeUTC+            , "name" .= bmName bm+            , "path" .= bmPath bm+            , "size" .= bmSize bm+            ]++instance ToGVal m BackendMeta where+    toGVal bm =+        let (mtime, mtimeSci, mtimeUTC) = mtimeFlavors bm+        in Ginger.dict+            [ "type" ~> decodeUtf8 (bmMimeType bm)+            , "mtime" ~> mtimeSci+            , "mtimeUTC" ~> mtimeUTC+            , "name" ~> bmName bm+            , "path" ~> bmPath bm+            , "size" ~> bmSize bm+            ]++
+ src/Web/Sprinkles/Backends/Loader.hs view
@@ -0,0 +1,31 @@+{-#LANGUAGE NoImplicitPrelude #-}+{-#LANGUAGE OverloadedStrings #-}+{-#LANGUAGE TypeFamilies #-}+{-#LANGUAGE MultiParamTypeClasses #-}+{-#LANGUAGE FlexibleInstances #-}+{-#LANGUAGE FlexibleContexts #-}+{-#LANGUAGE LambdaCase #-}++-- | Backend loader type+module Web.Sprinkles.Backends.Loader+( loader+)+where++import ClassyPrelude+import Web.Sprinkles.Backends.Loader.Type+import Web.Sprinkles.Backends.Loader.SqlLoader+import Web.Sprinkles.Backends.Loader.SubprocessLoader+import Web.Sprinkles.Backends.Loader.FileLoader+import Web.Sprinkles.Backends.Loader.HttpLoader+import Web.Sprinkles.Backends.Loader.RequestBodyLoader+import Web.Sprinkles.Backends.Loader.LiteralLoader+import Web.Sprinkles.Backends.Spec++loader :: BackendType -> Loader+loader (SqlBackend dsn query params) = sqlLoader dsn query params+loader (FileBackend filepath) = fileLoader filepath+loader (HttpBackend uriText credentials) = curlLoader uriText credentials+loader (SubprocessBackend cmd args mimeType) = subprocessLoader cmd args mimeType+loader RequestBodyBackend = requestBodyLoader+loader (LiteralBackend body) = literalLoader body
+ src/Web/Sprinkles/Backends/Loader/FileLoader.hs view
@@ -0,0 +1,127 @@+{-#LANGUAGE NoImplicitPrelude #-}+{-#LANGUAGE OverloadedStrings #-}+{-#LANGUAGE TypeFamilies #-}+{-#LANGUAGE MultiParamTypeClasses #-}+{-#LANGUAGE FlexibleInstances #-}+{-#LANGUAGE FlexibleContexts #-}+{-#LANGUAGE LambdaCase #-}++-- | File backend loader+module Web.Sprinkles.Backends.Loader.FileLoader+( fileLoader+)+where++import ClassyPrelude+import Web.Sprinkles.Backends.Data+        ( BackendData (..)+        , BackendMeta (..)+        , BackendSource (..)+        , Items (..)+        , reduceItems+        , RawBytes (..)+        , rawFromLBS, rawToLBS+        )+import System.FilePath (takeFileName, takeBaseName)+import System.FilePath.Glob (glob)+import System.Directory (doesDirectoryExist, getDirectoryContents)+import Web.Sprinkles.Logger (LogLevel (..))+import Web.Sprinkles.Backends.Loader.Type+import Network.Mime+            ( MimeType+            , MimeMap+            , defaultMimeLookup+            , defaultMimeMap+            , mimeByExt+            , defaultMimeType+            , FileName+            )+import System.PosixCompat.Files+import System.IO (withBinaryFile, IOMode (..), hSeek, SeekMode (..))+import Data.ByteString (hGet)++fileLoader :: Text -> Loader+fileLoader filepath writeLog _ fetchMode fetchOrder =+    fetch `catchIOError` handle+    where+        filename = unpack filepath+        fetch = do+            writeLog Debug $ "FILE: " <> filepath+            candidates <- if '*' `elem` filename+                then glob filename+                else return [filename]+            mapM fetchOne candidates+        handle err+            | isDoesNotExistError err = do+                writeLog Notice $ "FILE: Not found: " <> filepath+                return []+            | otherwise = ioError err++        fetchOne candidate = do+            isDir <- doesDirectoryExist candidate+            if isDir+                then fetchAsDir candidate+                else fetchAsFile candidate+        fetchAsDir candidate = do+            let mimeType = "application/x-directory"+            contents <- (encodeUtf8 . unlines . fmap pack <$> getDirectoryContents candidate)+                `catchIOError` \err -> do+                    writeLog Notice $ tshow err+                    return ""+            mkFileBackendSource mimeType candidate (rawFromLBS contents)++        fetchAsFile candidate = do+            let mimeType = mimeLookup . pack $ candidate+                contents = rawFromFile writeLog candidate+            mkFileBackendSource mimeType candidate contents++silenceIO :: (LogLevel -> Text -> IO ()) -> a -> IO a -> IO a+silenceIO writeLog defVal action =+    action+        `catchIOError` \err -> do+            writeLog Notice $ tshow err+            return defVal++rawFromFile :: (LogLevel -> Text -> IO ()) -> FilePath -> RawBytes+rawFromFile writeLog candidate =+    let getSize = silenceIO writeLog 0 $ fromIntegral . fileSize <$> getFileStatus candidate+        getRange start end = silenceIO writeLog "" $ do+            withBinaryFile candidate ReadMode $ \h -> do+                hSeek h AbsoluteSeek start+                fromStrict <$> hGet h (fromIntegral end)+    in RawBytes getSize getRange++mkFileBackendSource :: MimeType -> FilePath -> RawBytes -> IO BackendSource+mkFileBackendSource mimeType candidate contents = do+    status <- getFileStatus candidate+    let mtimeUnix = modificationTime status+        meta = BackendMeta+                { bmMimeType = mimeType+                , bmMTime = Just . realToFrac $ mtimeUnix+                , bmName = pack $ takeBaseName candidate+                , bmPath = pack candidate+                , bmSize = Just . fromIntegral $ fileSize status :: Maybe Integer+                }+    return $ BackendSource meta contents++-- | Our own extended MIME type dictionary. The default one lacks appropriate+-- entries for some of the important types we use, so we add them here.+mimeMap :: MimeMap+mimeMap =+    mapFromList+        [ ("yml", "application/x-yaml")+        , ("yaml", "application/x-yaml")+        , ("md", "application/x-markdown")+        , ("rst", "text/x-rst")+        , ("textile", "text/x-textile")+        , ("creole", "text/x-creole")+        , ("markdown", "application/x-markdown")+        , ("docx", "application/vnd.openxmlformats-officedocument.wordprocessingml.document")+        ]+    <> defaultMimeMap++-- | Custom MIME lookup function that knows about the extra types declared in+-- 'mimeMap'.+mimeLookup :: FileName -> MimeType+mimeLookup = mimeByExt mimeMap defaultMimeType+
+ src/Web/Sprinkles/Backends/Loader/HttpLoader.hs view
@@ -0,0 +1,81 @@+{-#LANGUAGE NoImplicitPrelude #-}+{-#LANGUAGE OverloadedStrings #-}+{-#LANGUAGE TypeFamilies #-}+{-#LANGUAGE MultiParamTypeClasses #-}+{-#LANGUAGE FlexibleInstances #-}+{-#LANGUAGE FlexibleContexts #-}+{-#LANGUAGE LambdaCase #-}++-- | HTTP backend loader+module Web.Sprinkles.Backends.Loader.HttpLoader+( curlLoader+)+where++import ClassyPrelude+import Web.Sprinkles.Backends.Spec+        ( HttpBackendOptions (..)+        )+import Web.Sprinkles.Backends.Data+        ( BackendData (..)+        , BackendMeta (..)+        , BackendSource (..)+        , Items (..)+        , reduceItems+        , rawFromLBS+        )+import Web.Sprinkles.Logger (LogLevel (..))+import Web.Sprinkles.Backends.Loader.Type+import Network.URI (parseURI, URI)+import System.FilePath (takeFileName, takeBaseName)+import Network.Curl (CurlOption (..))+import qualified Network.Curl as Curl+import Data.Char (isSpace)++data HttpError = HttpError String+    deriving (Show, Eq)++instance Exception HttpError where++curlLoader :: Text -> HttpBackendOptions -> Loader+curlLoader uriText options writeLog _ fetchMode fetchOrder = do+    let accepts = intercalate "," . map (unpack . decodeUtf8) $ httpAcceptedContentTypes options+    writeLog Debug $ "cURL " <> uriText+    Curl.initialize >>= \curl -> do+        response <- Curl.curlGetResponse_+            (unpack uriText)+            [ Curl.CurlFollowLocation True+            , Curl.CurlPostRedirect True+            , Curl.CurlFailOnError False+            , Curl.CurlUserAgent "sprinkles https://sprinkles.tobiasdammers.nl/"+            , Curl.CurlHttpHeaders+                [ "Accept: " ++ accepts ]+            ]+        let headersL = Curl.respHeaders response+            headers :: HashMap Text Text+            headers = mapFromList+                [(pack . toLower $ k, dropWhile isSpace . pack $ v) | (k, v) <- headersL ]+            getHeader :: Text -> Maybe Text+            getHeader hname = lookup hname headers+            getHeaderDef def = fromMaybe def . getHeader+            mimeType = encodeUtf8 $ getHeaderDef "text/plain" "content-type"+            contentLength = readMay . unpack =<< getHeader "content-length"+        writeLog Debug $ (pack . show) (Curl.respCurlCode response)+        writeLog Debug $ pack (Curl.respStatusLine response)+        writeLog Debug $ "Content-type: " <> decodeUtf8 mimeType+        writeLog Debug $ "Content-length: " <> maybe "?" (pack . show) contentLength+        if Curl.respStatus response /= 200+            then do+                writeLog Warning $ "HTTP error: " <> uriText <> " - " <> pack (Curl.respStatusLine response)+                return []+            else do+                -- TODO: support Range requests on the backend+                let body = rawFromLBS $ Curl.respBody response+                    meta = BackendMeta+                            { bmMimeType = mimeType+                            , bmMTime = Nothing+                            , bmName = pack . takeBaseName . unpack $ uriText+                            , bmPath = uriText+                            , bmSize = contentLength+                            }+                return [BackendSource meta body]
+ src/Web/Sprinkles/Backends/Loader/LiteralLoader.hs view
@@ -0,0 +1,48 @@+{-#LANGUAGE NoImplicitPrelude #-}+{-#LANGUAGE OverloadedStrings #-}+{-#LANGUAGE TypeFamilies #-}+{-#LANGUAGE MultiParamTypeClasses #-}+{-#LANGUAGE FlexibleInstances #-}+{-#LANGUAGE FlexibleContexts #-}+{-#LANGUAGE LambdaCase #-}++-- | Literal backend loader+module Web.Sprinkles.Backends.Loader.LiteralLoader+( literalLoader+)+where++import ClassyPrelude+import Web.Sprinkles.Backends.Data+        ( BackendData (..)+        , BackendMeta (..)+        , BackendSource (..)+        , Items (..)+        , reduceItems+        , RawBytes (..)+        , rawFromLBS+        )+import Web.Sprinkles.Logger (LogLevel (..))+import Data.Aeson as JSON+import Data.Aeson.TH as JSON+import Data.Yaml as YAML+import Web.Sprinkles.Backends.Loader.Type++literalLoader :: JSON.Value -> Loader+literalLoader body writeLog _ fetchMode fetchOrder = do+    let (mimeType, rawBodyBytes) = case body of+            String txt -> ( "text/plain;charset=utf8"+                          , fromStrict (encodeUtf8 txt)+                          )+            _ -> ( "application/json"+                 , JSON.encode body+                 )+        rawBody = rawFromLBS rawBodyBytes+    let meta = BackendMeta+            { bmMimeType = mimeType+            , bmMTime = Nothing+            , bmName = "literal"+            , bmPath = "literal"+            , bmSize = Just . fromIntegral $ length rawBodyBytes+            }+    return [ BackendSource meta rawBody ]
+ src/Web/Sprinkles/Backends/Loader/RequestBodyLoader.hs view
@@ -0,0 +1,46 @@+{-#LANGUAGE NoImplicitPrelude #-}+{-#LANGUAGE OverloadedStrings #-}+{-#LANGUAGE TypeFamilies #-}+{-#LANGUAGE MultiParamTypeClasses #-}+{-#LANGUAGE FlexibleInstances #-}+{-#LANGUAGE FlexibleContexts #-}+{-#LANGUAGE LambdaCase #-}++-- | File backend loader+module Web.Sprinkles.Backends.Loader.RequestBodyLoader+( requestBodyLoader+)+where++import ClassyPrelude+import Web.Sprinkles.Backends.Data+        ( BackendData (..)+        , BackendMeta (..)+        , BackendSource (..)+        , Items (..)+        , reduceItems+        , rawFromLBS+        )+import Web.Sprinkles.Logger (LogLevel (..))+import Web.Sprinkles.Backends.Loader.Type+import Network.Mime+            ( MimeType+            , MimeMap+            , defaultMimeLookup+            , defaultMimeMap+            , mimeByExt+            , defaultMimeType+            , FileName+            )++requestBodyLoader :: Loader+requestBodyLoader writeLog pbs fetchMode fetchOrder = do+    contents <- rawFromLBS <$> loadPost pbs+    let meta = BackendMeta+                { bmMimeType = contentType pbs+                , bmMTime = Nothing+                , bmName = "POST"+                , bmPath = "POST"+                , bmSize = Nothing+                }+    return [BackendSource meta contents]
+ src/Web/Sprinkles/Backends/Loader/SqlLoader.hs view
@@ -0,0 +1,60 @@+{-#LANGUAGE NoImplicitPrelude #-}+{-#LANGUAGE OverloadedStrings #-}+{-#LANGUAGE TypeFamilies #-}+{-#LANGUAGE MultiParamTypeClasses #-}+{-#LANGUAGE FlexibleInstances #-}+{-#LANGUAGE FlexibleContexts #-}+{-#LANGUAGE LambdaCase #-}++-- | SQL backend loader+module Web.Sprinkles.Backends.Loader.SqlLoader+( sqlLoader+)+where++import ClassyPrelude+import Web.Sprinkles.Backends.Data+        ( BackendData (..)+        , BackendMeta (..)+        , BackendSource (..)+        , Items (..)+        , reduceItems+        , rawFromLBS+        )+import qualified Database.HDBC as HDBC+import qualified Web.Sprinkles.Databases as DB+import Web.Sprinkles.Databases (DSN (..), sqlDriverFromID)+import Web.Sprinkles.Logger (LogLevel (..))+import Data.Aeson as JSON+import Data.Aeson.TH as JSON+import Data.Yaml as YAML+import Web.Sprinkles.Backends.Loader.Type++sqlLoader :: DSN -> Text -> [Text] -> Loader+sqlLoader dsn query params writeLog _ fetchMode fetchOrder = do+    rows <- DB.withConnection dsn $ \conn -> do+        HDBC.withTransaction conn $ \conn -> do+            writeLog Debug $+                "SQL: QUERY: " <> tshow query <>+                " ON " <> DB.dsnToText dsn <>+                " WITH: " <> tshow params+            stmt <- HDBC.prepare conn (unpack query)+            HDBC.execute stmt (map HDBC.toSql params)+            HDBC.fetchAllRowsMap stmt+    return $ map mapRow rows+    where+        mapRow :: Map String HDBC.SqlValue -> BackendSource+        mapRow row =+            let json = JSON.encode (fmap (HDBC.fromSql :: HDBC.SqlValue -> Text) row)+                name = maybe "SQL" HDBC.fromSql $+                    lookup "name" row <|>+                    lookup "title" row <|>+                    (headMay . fmap snd . mapToList $ row)+                meta = BackendMeta+                        { bmMimeType = "application/json"+                        , bmMTime = Nothing+                        , bmName = name+                        , bmPath = "SQL"+                        , bmSize = Just . fromIntegral $ length json+                        }+            in BackendSource meta (rawFromLBS json)
+ src/Web/Sprinkles/Backends/Loader/SubprocessLoader.hs view
@@ -0,0 +1,43 @@+{-#LANGUAGE NoImplicitPrelude #-}+{-#LANGUAGE OverloadedStrings #-}+{-#LANGUAGE TypeFamilies #-}+{-#LANGUAGE MultiParamTypeClasses #-}+{-#LANGUAGE FlexibleInstances #-}+{-#LANGUAGE FlexibleContexts #-}+{-#LANGUAGE LambdaCase #-}++-- | Subprocess backend loader+module Web.Sprinkles.Backends.Loader.SubprocessLoader+( subprocessLoader+)+where++import ClassyPrelude+import Web.Sprinkles.Backends.Data+        ( BackendData (..)+        , BackendMeta (..)+        , BackendSource (..)+        , Items (..)+        , reduceItems+        , rawFromLBS+        )+import Web.Sprinkles.Backends.Loader.Type+import Network.Mime (MimeType)+import Web.Sprinkles.Logger (LogLevel (..))+import qualified System.Process as Process++subprocessLoader :: Text -> [Text] -> MimeType -> Loader+subprocessLoader cmd args mimeType writeLog _ fetchMode fetchOrder = do+    (_, Just hOut, _, _) <-+        Process.createProcess+            (Process.proc (unpack cmd) (map unpack args)) { Process.std_out = Process.CreatePipe }+    body <- hGetContents hOut+    let contentLength = fromIntegral $ length body+    let meta = BackendMeta+                { bmMimeType = mimeType+                , bmMTime = Nothing+                , bmName = cmd+                , bmPath = unwords $ cmd:args+                , bmSize = Just contentLength+                }+    return [BackendSource meta (rawFromLBS body)]
+ src/Web/Sprinkles/Backends/Loader/Type.hs view
@@ -0,0 +1,55 @@+{-#LANGUAGE NoImplicitPrelude #-}+{-#LANGUAGE OverloadedStrings #-}+{-#LANGUAGE TypeFamilies #-}+{-#LANGUAGE MultiParamTypeClasses #-}+{-#LANGUAGE FlexibleInstances #-}+{-#LANGUAGE FlexibleContexts #-}+{-#LANGUAGE LambdaCase #-}++-- | Backend loader type+module Web.Sprinkles.Backends.Loader.Type+where++import ClassyPrelude+import qualified Network.Wai as Wai++import Web.Sprinkles.Backends.Data+        ( BackendData (..)+        , BackendMeta (..)+        , BackendSource (..)+        , Items (..)+        , reduceItems+        )+import Web.Sprinkles.Backends.Spec+        ( FetchMode (..)+        , FetchOrder (..)+        )+import Web.Sprinkles.Logger (LogLevel)++data PostBodySource =+    PostBodySource+        { loadPost :: IO LByteString+        , contentType :: ByteString+        }++type Loader = (LogLevel -> Text -> IO ())+            -> PostBodySource+            -> FetchMode+            -> FetchOrder+            -> IO [BackendSource]++pbsFromRequest :: Wai.Request -> PostBodySource+pbsFromRequest request =+    PostBodySource+        { loadPost = Wai.lazyRequestBody request+        , contentType = fromMaybe "text/plain" $+            lookup "Content-type" (Wai.requestHeaders request)+        }++pbsInvalid :: PostBodySource+pbsInvalid =+    PostBodySource+        { loadPost = fail "POST body not available"+        , contentType = "text/plain"+        }+
+ src/Web/Sprinkles/Backends/Parsers.hs view
@@ -0,0 +1,186 @@+{-#LANGUAGE NoImplicitPrelude #-}+{-#LANGUAGE OverloadedStrings #-}+{-#LANGUAGE TypeFamilies #-}+{-#LANGUAGE MultiParamTypeClasses #-}+{-#LANGUAGE FlexibleInstances #-}+{-#LANGUAGE FlexibleContexts #-}+{-#LANGUAGE LambdaCase #-}+{-#LANGUAGE TupleSections #-}++-- | Parse raw backend data into useful data structures.+module Web.Sprinkles.Backends.Parsers+( parseBackendData+)+where++import ClassyPrelude++import Web.Sprinkles.Backends.Data+        ( BackendData (..)+        , BackendMeta (..)+        , BackendSource (..)+        , toBackendData+        , addBackendDataChildren+        , rawToLBS, rawFromLBS+        )+import Web.Sprinkles.Backends.Spec+        ( parserTypes+        , ParserType (..)+        )+import Text.Pandoc (Pandoc)+import qualified Text.Pandoc as Pandoc+import qualified Text.Pandoc.MediaBag as Pandoc+import qualified Text.Pandoc.Readers.Creole as Pandoc+import Text.Pandoc.Error (PandocError)+import Network.Mime (MimeType)+import Text.Ginger (ToGVal (..), GVal, Run (..), dict, (~>))+import qualified Data.Aeson as JSON+import qualified Data.Aeson.TH as JSON+import qualified Data.Yaml as YAML+import Data.Char (ord)+import Web.Sprinkles.PandocGVal+import Network.HTTP.Types (parseQuery, queryToQueryText)++-- | Parse raw backend data source into a structured backend data record.+parseBackendData :: (MonadIO m, Monad m, Monad n)+                 => BackendSource+                 -> m (BackendData n h)+parseBackendData item@(BackendSource meta body) = do+    let t = takeWhile (/= fromIntegral (ord ';')) (bmMimeType meta)+        parse = fromMaybe parseRawData $ lookup t parsersTable+    parse item++-- | Lookup table of mime types to parsers.+parsersTable :: (MonadIO m, Monad m, Monad n)+             => HashMap MimeType (BackendSource -> m (BackendData n h))+parsersTable = mapFromList . mconcat $+    [ zip mimeTypes (repeat parser) | (mimeTypes, parser) <- parsers ]++-- | The parsers we know, by mime types.+parsers :: (MonadIO m, Monad m, Monad n)+        => [([MimeType], BackendSource -> m (BackendData n h))]+parsers =+    [ (types, getParser p) | (types, p) <- parserTypes ]++getParser :: (MonadIO m, Monad m, Monad n)+          => ParserType+          -> (BackendSource -> m (BackendData n h))+getParser ParserJSON = json+getParser ParserYAML = yaml+getParser ParserFormUrlencoded = urlencodedForm+getParser ParserMarkdown = pandoc (Pandoc.readMarkdown Pandoc.def)+getParser ParserCreole = pandoc (Pandoc.readCreole Pandoc.def)+getParser ParserTextile = pandoc (Pandoc.readTextile Pandoc.def)+getParser ParserRST = pandoc (Pandoc.readRST Pandoc.def)+getParser ParserLaTeX = pandoc (Pandoc.readLaTeX Pandoc.def)+getParser ParserDocX = pandocWithMedia (Pandoc.readDocx Pandoc.def)+getParser ParserText = plainText+getParser ParserHtml = pandoc (Pandoc.readHtml Pandoc.def)++-- | All the content types we know how to parse+knownContentTypes :: [MimeType]+knownContentTypes = concatMap fst parserTypes++-- | Parser for raw data (used for static files); this is also the default+-- fallback for otherwise unsupported file types.+parseRawData :: Monad m => BackendSource -> m (BackendData n h)+parseRawData (BackendSource meta body) =+    return BackendData+        { bdJSON = JSON.Null+        , bdGVal = toGVal JSON.Null+        , bdMeta = meta+        , bdRaw = body+        , bdChildren = mapFromList []+        }++-- | Parser for (utf-8) plaintext documents.+plainText :: (MonadIO m, Monad m) => BackendSource -> m (BackendData n h)+plainText item@(BackendSource meta body) = do+    textBody <- liftIO $ toStrict . decodeUtf8 <$> rawToLBS body+    return $ toBackendData item textBody++-- | Parser for JSON source data.+json :: (MonadIO m, Monad m) => BackendSource -> m (BackendData n h)+json item@(BackendSource meta body) = do+    bodyBytes <- liftIO $ rawToLBS body+    case JSON.eitherDecode bodyBytes of+        Left err -> fail $ err ++ "\n" ++ show bodyBytes+        Right json -> return . toBackendData item $ (json :: JSON.Value)++-- | Parser for YAML source data.+yaml :: (MonadIO m, Monad m) => BackendSource -> m (BackendData n h)+yaml item@(BackendSource meta body) = do+    bodyBytes <- liftIO $ rawToLBS body+    case YAML.decodeEither (toStrict bodyBytes) of+        Left err -> fail $ err ++ "\n" ++ show bodyBytes+        Right json -> return . toBackendData item $ (json :: JSON.Value)++urlencodedForm :: (MonadIO m, Monad m) => BackendSource -> m (BackendData n h)+urlencodedForm item@(BackendSource meta body) = do+    bodyBytes <- liftIO $ rawToLBS body+    return .+        toBackendData item .+        asTextHashMap .+        mapFromList .+        queryToQueryText .+        parseQuery .+        toStrict $ bodyBytes+    where+        asTextHashMap :: HashMap Text (Maybe Text) -> HashMap Text (Maybe Text)+        asTextHashMap = id++-- | Parser for Pandoc-supported formats that are read from 'LByteString's.+pandocBS :: (MonadIO m, Monad m, Monad n)+         => (LByteString -> Either PandocError Pandoc)+         -> BackendSource+         -> m (BackendData n h)+pandocBS reader input@(BackendSource meta body) = do+    bodyBytes <- liftIO $ rawToLBS body+    case reader bodyBytes of+        Left err -> fail . show $ err+        Right pandoc -> return $ toBackendData input pandoc++-- | Parser for Pandoc-supported formats that are read from 'LByteString's, and+-- return a 'Pandoc' document plus a 'MediaBag'.+pandocWithMedia :: (MonadIO m, Monad m, Monad n)+                => (LByteString -> Either PandocError (Pandoc, Pandoc.MediaBag))+                -> BackendSource+                -> m (BackendData n h)+pandocWithMedia reader input@(BackendSource meta body) = do+    bodyBytes <- liftIO $ rawToLBS body+    case reader bodyBytes of+        Left err -> fail . show $ err+        Right (pandoc, mediaBag) -> do+            -- TODO: marshal mediaBag to backend data item children+            let base = toBackendData input pandoc+            children <- mapFromList <$> mediaBagToBackendData mediaBag+            return $ addBackendDataChildren children base++mediaBagToBackendData :: (MonadIO m, Monad m, Monad n)+                      => Pandoc.MediaBag+                      -> m [(Text, BackendData n h)]+mediaBagToBackendData bag = do+    let metas = Pandoc.mediaDirectory bag+    forM metas $ \(path, mimeType, contentLength) -> do+        (_, body) <- maybe+                        (fail $ "Media not found: " <> path)+                        return+                        (Pandoc.lookupMedia path bag)+        let meta =+                BackendMeta+                    { bmMimeType = encodeUtf8 . pack $ mimeType+                    , bmMTime = Nothing+                    , bmName = pack path+                    , bmPath = pack path+                    , bmSize = Just $ fromIntegral contentLength+                    }+        (pack path,) <$> parseBackendData (BackendSource meta (rawFromLBS body))++-- | Parser for Pandoc-supported formats that are read from 'String's.+pandoc :: (MonadIO m, Monad m, Monad n)+       => (String -> Either PandocError Pandoc)+       -> BackendSource+       -> m (BackendData n h)+pandoc reader =+    pandocBS (reader . unpack . decodeUtf8)+
+ src/Web/Sprinkles/Backends/Spec.hs view
@@ -0,0 +1,468 @@+{-#LANGUAGE NoImplicitPrelude #-}+{-#LANGUAGE OverloadedStrings #-}+{-#LANGUAGE TypeFamilies #-}+{-#LANGUAGE MultiParamTypeClasses #-}+{-#LANGUAGE FlexibleInstances #-}+{-#LANGUAGE FlexibleContexts #-}+{-#LANGUAGE LambdaCase #-}+{-#LANGUAGE DeriveGeneric #-}++-- | Backend spec types and parser+module Web.Sprinkles.Backends.Spec+(+-- * Defining backends+  BackendSpec (..)+, BackendType (..)+, FetchOrderField (..)+, FetchMode (..)+, AscDesc (..)+, FetchOrder (..)+, parseBackendURI+, Credentials (..)+, HttpMethod (..)+, HttpBackendOptions (..)+, CachePolicy (..)+, HasCachePolicy (..)+, ParserType (..)+, parserTypes+)+where++import ClassyPrelude+import Network.Mime (MimeType)+import Network.HTTP.Types ()+import Data.Aeson (FromJSON (..), Value (..), (.=), (.!=), (.:?), (.:))+import qualified Data.Aeson as JSON+import System.PosixCompat.Files+import Data.Default (Default (..))+import Web.Sprinkles.Cache+import qualified Data.Serialize as Cereal+import Data.Serialize (Serialize)+import Web.Sprinkles.Databases (DSN (..), sqlDriverFromID)+import Web.Sprinkles.Logger (LogLevel (..))+import Data.Walk (walk)++-- | A type of backend.+data BackendType = HttpBackend Text HttpBackendOptions -- ^ Fetch data over HTTP(S)+                 | FileBackend Text -- ^ Read local files+                 | SqlBackend DSN Text [Text] -- ^ Query an SQL database+                 | SubprocessBackend Text [Text] MimeType -- ^ Run a command in a subprocess+                 | RequestBodyBackend -- ^ Read the incoming request body+                 | LiteralBackend Value -- ^ Return literal data from the spec itself+                 deriving (Show, Generic)++instance Serialize BackendType where+    put (HttpBackend url options) = do+        Cereal.put 'h'+        Cereal.put (encodeUtf8 . unpack $ url)+        Cereal.put options+    put (FileBackend path) = do+        Cereal.put 'f'+        Cereal.put (encodeUtf8 . unpack $ path)+    put (SqlBackend dsn query params) = do+        Cereal.put 's'+        Cereal.put dsn+        Cereal.put (encodeUtf8 . unpack $ query)+        Cereal.put (map (encodeUtf8 . unpack) params)+    put (SubprocessBackend cmd args t) = do+        Cereal.put 'p'+        Cereal.put (encodeUtf8 . unpack $ cmd)+        Cereal.put (map (encodeUtf8 . unpack) args)+        Cereal.put t+    put RequestBodyBackend = Cereal.put 'b'+    put (LiteralBackend b) = do+        Cereal.put 'l'+        Cereal.put (JSON.encode b)+    get = Cereal.get >>= \case+            'h' -> HttpBackend <$> (pack . decodeUtf8 <$> Cereal.get) <*> Cereal.get+            'f' -> FileBackend <$> (pack . decodeUtf8 <$> Cereal.get)+            's' -> SqlBackend <$>+                    Cereal.get <*>+                    (pack . decodeUtf8 <$> Cereal.get) <*>+                    (map (pack . decodeUtf8) <$> Cereal.get)+            'p' -> SubprocessBackend <$>+                    (pack . decodeUtf8 <$> Cereal.get) <*>+                    (map (pack . decodeUtf8) <$> Cereal.get) <*>+                    Cereal.get+            'b' -> return RequestBodyBackend+            'l' -> LiteralBackend <$>+                    (fromMaybe JSON.Null . JSON.decode <$> Cereal.get)+            x -> fail $ "Invalid backend type identifier: " <> show x++type instance Element BackendType = Text++instance MonoFunctor BackendType where+    omap f (HttpBackend t c) = HttpBackend (f t) c+    omap f (FileBackend t) = FileBackend (f t)+    omap f (SqlBackend dsn query params) = SqlBackend (omap f dsn) query (map f params)+    omap f (SubprocessBackend cmd args t) = SubprocessBackend cmd (map f args) t+    omap _ RequestBodyBackend = RequestBodyBackend+    omap f (LiteralBackend b) =+        LiteralBackend (walk f b)++-- | A specification of a backend query.+data BackendSpec =+    BackendSpec+        { bsType :: BackendType -- ^ Defines the data source+        , bsFetchMode :: FetchMode -- ^ How many items to fetch, and in what shape+        , bsOrder :: FetchOrder -- ^ How to order items+        -- | If set, ignore reported MIME type and use this one instead.+        , bsMimeTypeOverride :: Maybe MimeType+        }+        deriving (Show, Generic)++instance Serialize BackendSpec++type instance Element BackendSpec = Text++instance MonoFunctor BackendSpec where+    omap f (BackendSpec t m o mto) = BackendSpec (omap f t) m o mto++-- | The JSON shape of a backend spec is:+--+-- @+-- {+--   // type: one of:+--   // - "http" (fetch over HTTP)+--   // - "https" (fetch over HTTPS)+--   // - "file" (load an individual file)+--   // - "glob" (resolve a glob and load all matching files)+--   // - "dir" (get a directory listing)+--   // - "sql" (query an SQL database)+--   // - "subprocess" (execute a subprocess and read its stdout)+--   // - "post" (get the request body; only for POST requests)+--   // - "literal" (return literal value as specified)+--   "type": type,+--+--   // fetch mode. One of:+--   - "one": Fetch exactly one item, as a scalar+--   - "all": Fetch all items, as a list+--   - n (numeric value): Fetch up to n items, as a list+--   "fetch": fetchMode,+--+--   // ordering. One of:+--   // - "arbitrary": do not reorder, use whatever the backend produces+--   // - "random": random-shuffle results+--   // - "shuffle": same as "random"+--   // - "name": order by name+--   // - "mtime": order by modification time+--   // The ordering can be preceded with a "+" or "-" sign to indicate+--   // ascending or descending ordering.+--   "order": ordering,+--+--   // The rest of the structure depends on the type.+--+--   // For "http" and "https":+--   // The HTTP(S) URI to load from+--   "uri": uri,+--+--   // For "file", "glob", "dir":+--   // The local file path or glob+--   "path": path+-- }+-- @+instance FromJSON BackendSpec where+    parseJSON = backendSpecFromJSON++-- | Read a backend spec from a JSON value.+backendSpecFromJSON (String uri) =+    parseBackendURI uri+backendSpecFromJSON (Object obj) = do+    bsTypeStr <- obj .: "type"+    (t, defFetchMode) <- case bsTypeStr :: Text of+            "http" -> parseHttpBackendSpec+            "https" -> parseHttpBackendSpec+            "file" -> parseFileBackendSpec FetchOne+            "glob" -> parseFileBackendSpec FetchAll+            "dir" -> parseDirBackendSpec+            "sql" -> parseSqlBackendSpec+            "subprocess" -> parseSubprocessSpec+            "post" -> return (RequestBodyBackend, FetchOne)+            "literal" -> parseLiteralBackendSpec+            x -> fail $ "Invalid backend specifier: " ++ show x+    fetchMode <- obj .:? "fetch" .!= defFetchMode+    fetchOrder <- obj .:? "order" .!= def+    mimeOverride <- fmap encodeUtf8 <$> obj .:? "force-mime-type"+    return $ BackendSpec t fetchMode fetchOrder mimeOverride+    where+        parseHttpBackendSpec = do+            t <- obj .: "uri"+            return (HttpBackend t def, FetchOne)+        parseFileBackendSpec m = do+            path <- obj .: "path"+            return (FileBackend (pack path), m)+        parseDirBackendSpec = do+            path <- obj .: "path"+            return (FileBackend (pack $ path </> "*"), FetchAll)+        parseSqlBackendSpec = do+            dsn <- obj .: "connection"+            query <- obj .: "query"+            params <- obj .:? "params" .!= []+            return (SqlBackend dsn query params, FetchAll)+        parseSubprocessSpec = do+            rawCmd <- obj .: "cmd"+            t <- fromString <$> (obj .:? "mime-type" .!= "text/plain")+            case rawCmd of+                String cmd -> return (SubprocessBackend cmd [] t, FetchOne)+                Array v -> parseJSON rawCmd >>= \case+                    cmd:args -> return (SubprocessBackend cmd args t, FetchOne)+                    [] -> fail "Expected a command and a list of arguments"+        parseLiteralBackendSpec = do+            b <- obj .:? "body" .!= JSON.Null+            return (LiteralBackend b, FetchOne)++backendSpecFromJSON x = fail $ "Invalid JSON value for BackendSpec: " <> show x <> ", expecting object or string"++-- | Parse a 'Text' into a 'BackendSpec'.+parseBackendURI :: Monad m => Text -> m BackendSpec+parseBackendURI t = do+    let protocol = takeWhile (/= ':') t+        path = drop (length protocol + 3) t+    case protocol of+        "http" ->+            return $+                BackendSpec+                    (HttpBackend t def)+                    FetchOne+                    def+                    Nothing+        "https" ->+            return $+                BackendSpec+                    (HttpBackend t def)+                    FetchOne+                    def+                    Nothing+        "dir" -> return $+            BackendSpec (FileBackend (pack $ unpack path </> "*")) FetchAll def Nothing+        "glob" -> return $+            BackendSpec (FileBackend path) FetchAll def Nothing+        "file" -> return $+            BackendSpec (FileBackend path) FetchOne def Nothing+        "sql" -> do+            be <- parseSqlBackendURI path+            return $ BackendSpec be FetchAll def Nothing+        "post" ->+            return $+                BackendSpec+                    RequestBodyBackend+                    FetchOne def Nothing+        "literal" ->+            return $+                BackendSpec+                    (LiteralBackend $ JSON.String path)+                    FetchOne def Nothing+        _ -> fail $ "Unknown protocol: " <> show protocol+    where+        parseSqlBackendURI path = do+            let driverID = takeWhile (/= ':') path+                remainder = drop (length driverID + 1) path+                details = takeWhile (/= ':') remainder+                query = drop (length details + 1) remainder+            driver <- maybe+                (fail $ "Invalid driver: " ++ show driverID)+                return+                (sqlDriverFromID driverID)+            return $ SqlBackend (DSN driver details) query []++-- | How many items to fetch, and in what shape.+data FetchMode = FetchOne -- ^ Fetch only the first result+               | FetchAll -- ^ Fetch all results+               | FetchN Int -- ^ Fetch at most @n@ results, starting from the top+    deriving (Show, Read, Eq, Generic)++instance Serialize FetchMode where++instance FromJSON FetchMode where+    parseJSON (String "one") = return FetchOne+    parseJSON (String "all") = return FetchAll+    parseJSON (Number n) = return . FetchN . ceiling $ n+    parseJSON _ = fail "Invalid fetch mode (want 'one' or 'all')"++-- | By which field should we order results?+data FetchOrderField = ArbitraryOrder -- ^ Do not impose any ordering at all+                     | RandomOrder -- ^ Shuffle randomly+                     | OrderByName -- ^ Order by reported name+                     | OrderByMTime -- ^ Order by modification time+                     deriving (Show, Read, Eq, Generic)++instance Serialize FetchOrderField where++instance Default FetchOrderField where+    def = ArbitraryOrder++data AscDesc = Ascending | Descending+    deriving (Show, Read, Eq, Generic)++instance Serialize AscDesc where++instance Default AscDesc where+    def = Ascending++-- | How to order results.+data FetchOrder =+    FetchOrder+        { fetchField :: FetchOrderField -- ^ By which field?+        , fetchAscDesc :: AscDesc -- ^ Reverse ordering?+        }+        deriving (Show, Read, Eq, Generic)++instance Serialize FetchOrder where++instance Default FetchOrder where+    def = FetchOrder def def++instance FromJSON FetchOrder where+    parseJSON Null = return $ FetchOrder ArbitraryOrder Ascending+    parseJSON (String str) = do+        let (order, core) = case take 1 str of+                "-" -> (Descending, drop 1 str)+                "+" -> (Ascending, drop 1 str)+                _ -> (Ascending, str)+        field <- case core of+            "arbitrary" -> return ArbitraryOrder+            "random" -> return RandomOrder+            "shuffle" -> return RandomOrder+            "name" -> return OrderByName+            "mtime" -> return OrderByMTime+            x -> fail $ "Invalid order field: " ++ show x+        return $ FetchOrder field order+    parseJSON val = fail $ "Invalid fetch order specifier: " ++ show val++-- | Credentials to pass to an external backend data source. Currently stubbed,+-- supporting only anonymous access.+data Credentials = AnonymousCredentials+    deriving (Show, Generic)++instance Serialize Credentials where++data HttpMethod = GET | POST+    deriving (Show, Generic)++instance Serialize HttpMethod where++data HttpBackendOptions =+    HttpBackendOptions+        { httpCredentials :: Credentials+        , httpHttpMethods :: HttpMethod+        , httpAcceptedContentTypes :: [MimeType]+        }+        deriving (Show, Generic)++instance Serialize HttpBackendOptions where++instance FromJSON Credentials where+    parseJSON Null = return AnonymousCredentials+    parseJSON (String "anonymous") = return AnonymousCredentials+    parseJSON _ = fail "Invalid credentials"++instance FromJSON HttpMethod where+    parseJSON (String str) =+        case toUpper str of+            "GET" -> return GET+            "POST" -> return POST+            x -> fail $ "Unsupported request method: " <> show x+    parseJSON _ = fail "Invalid request method, expected string"++instance FromJSON HttpBackendOptions where+    parseJSON Null = return def+    parseJSON (Object o) =+        HttpBackendOptions+            <$> (o .:? "credentials" .!= AnonymousCredentials)+            <*> (o .:? "method" .!= GET)+            <*> pure knownContentTypes++instance Default HttpBackendOptions where+    def = HttpBackendOptions+            AnonymousCredentials+            GET+            knownContentTypes++data CachePolicy = CacheForever+                 | NoCaching++class HasCachePolicy a where+    cachePolicy :: a -> CachePolicy++instance HasCachePolicy BackendSpec where+    cachePolicy = cachePolicy . bsType++instance HasCachePolicy BackendType where+    cachePolicy = \case+        RequestBodyBackend -> NoCaching+        _ -> CacheForever++data ParserType = ParserText+                | ParserJSON+                | ParserYAML+                | ParserFormUrlencoded+                | ParserMarkdown+                | ParserCreole+                | ParserTextile+                | ParserRST+                | ParserLaTeX+                | ParserDocX+                | ParserHtml+                deriving (Show, Read)++-- | The parsers we know, by mime types.+parserTypes :: [([MimeType], ParserType)]+parserTypes =+    [ ( [ "application/json", "text/json" ]+      , ParserJSON+      )+    , ( [ "application/x-yaml"+        , "text/x-yaml"+        , "application/yaml"+        , "text/yaml"+        ]+      , ParserYAML+      )+    , ( [ "application/x-www-form-urlencoded"+        ]+      , ParserFormUrlencoded+      )+    , ( [ "application/x-markdown"+        , "text/x-markdown"+        ]+      , ParserMarkdown+      )+    , ( [ "application/x-creole"+        , "text/x-creole"+        ]+      , ParserCreole+      )+    , ( [ "application/x-textile"+        , "text/x-textile"+        ]+      , ParserTextile+      )+    , ( [ "application/x-rst"+        , "text/x-rst"+        ]+      , ParserRST+      )+    , ( [ "application/x-latex"+        , "text/x-latex"+        , "application/x-tex"+        , "text/x-tex"+        ]+      , ParserLaTeX+      )+    , ( [ "application/vnd.openxmlformats-officedocument.wordprocessingml.document"+        ]+      , ParserDocX+      )+    , ( [ "text/plain" ]+      , ParserText+      )+    , ( [ "application/html"+        , "text/html"+        ]+      , ParserHtml+      )+    ]++-- | All the content types we know how to parse+knownContentTypes :: [MimeType]+knownContentTypes = concatMap fst parserTypes
+ src/Web/Sprinkles/Cache.hs view
@@ -0,0 +1,100 @@+{-#LANGUAGE NoImplicitPrelude #-}+{-#LANGUAGE OverloadedStrings #-}+{-#LANGUAGE OverloadedLists #-}+{-#LANGUAGE LambdaCase #-}+{-#LANGUAGE TupleSections #-}+module Web.Sprinkles.Cache+where++import ClassyPrelude+import Control.MaybeEitherMonad+import Data.Time.Clock.POSIX++-- | Common interface for cache backends.+-- In @Cache k v@, @k@ is the key type and @v@ the value type.+data Cache k v =+    Cache+        { cacheGet :: k -> IO (Maybe v) -- ^ Get 'Just' the cached value or 'Nothing'+        , cachePut :: k -> v -> IO () -- ^ Insert an entry into the cache+        , cacheDelete :: k -> IO () -- ^ Delete an entry from the cache+        , cacheVacuum :: IO Int -- ^ Delete all stale keys, return number of keys deleted+        }++instance Monoid (Cache k v) where+    mempty = nullCache+    mappend = appendCache++-- | @cacheFetch load cache key@ fetches a value at the @key@ from the @cache@,+-- failing over to the @load@ action when the key is not present in the cache,+-- and adding it to the cache.+cacheFetch :: (k -> IO v) -> Cache k v -> k -> IO v+cacheFetch load cache key = do+    entryMay <- cacheGet cache key+    case entryMay of+        Just value ->+            return value+        Nothing -> do+            value <- load key+            cachePut cache key value+            return value++cached :: Cache k v -> (k -> IO v) -> k -> IO v+cached = flip cacheFetch++-- | A cache that doesn't actually cache anything+nullCache :: Cache k v+nullCache =+    Cache+        { cacheGet = const $ return Nothing+        , cachePut = const . const $ return ()+        , cacheDelete = const $ return ()+        , cacheVacuum = return 0+        }++appendCache :: Cache k v -> Cache k v -> Cache k v+appendCache first second =+    Cache+        { cacheGet = \key -> cacheGet first key >>= \case+            Nothing ->+                cacheGet second key >>=+                    maybe+                        (return Nothing)+                        (\value -> do+                            cachePut first key value+                            return $ Just value+                        )+            Just value ->+                return $ Just value+        , cachePut = \key value -> do+            cachePut first key value+            cachePut second key value+        , cacheDelete = \key -> do+            cacheDelete first key+            cacheDelete second key+        , cacheVacuum = (+) <$> cacheVacuum first <*> cacheVacuum second+        }++-- | Wrap a cache such that the new cache uses different types for the keys+-- and values, using the provided transformation functions. A typical+-- application for this is to serialize data structures into a more palatable+-- format for caching while exposing a more useful kind of data structure+transformCache :: (k -> j)+               -> (j -> Maybe k)+               -> (v -> IO (Maybe u))+               -> (u -> IO (Maybe v))+               -> Cache j u+               -> Cache k v+transformCache transK+               untransK+               transV+               untransV+               innerCache =+    Cache+        { cacheGet = \key -> cacheGet innerCache (transK key) >>= \case+                Nothing -> return Nothing+                Just tval -> untransV tval+        , cachePut = \key value ->+            transV value >>= optionally (cachePut innerCache (transK key))+        , cacheDelete = cacheDelete innerCache . transK+        , cacheVacuum = cacheVacuum innerCache+        }
+ src/Web/Sprinkles/Cache/Filesystem.hs view
@@ -0,0 +1,88 @@+{-#LANGUAGE NoImplicitPrelude #-}+{-#LANGUAGE ScopedTypeVariables #-}+{-#LANGUAGE OverloadedStrings #-}+module Web.Sprinkles.Cache.Filesystem+where++import ClassyPrelude+import Data.Char (isAlphaNum, ord, isDigit, isAlpha, chr)+import Prelude (read)+import Web.Sprinkles.Cache+import System.IO (IOMode (..), withFile)+import System.Directory (removeFile, getDirectoryContents)+import System.FilePath (takeFileName)+import System.PosixCompat.Files (getFileStatus, modificationTime)+import Data.Time.Clock.POSIX+import Data.Char (isAsciiLower, isAsciiUpper, isDigit)++ignoreNonexisting :: a -> IOError -> IO a+ignoreNonexisting r err =+    if isDoesNotExistError err+        then return r+        else ioError err++ignoreNonexisting_ :: IOError -> IO ()+ignoreNonexisting_ = ignoreNonexisting ()++filesystemCache :: (k -> String) -- ^ Key serializer+                -> (String -> k) -- ^ Key deserializer+                -> (Handle -> v -> IO ()) -- ^ Value serializer+                -> (Handle -> IO v) -- ^ Value deserializer+                -> FilePath -- ^ Base directory+                -> POSIXTime -- ^ Expiration, in seconds+                -> Cache k v -- ^ Resulting cache+filesystemCache serializeKey deserializeKey writeValue readValue cacheDir maxAge =+    Cache+        { cacheGet = \key -> do+            let filename = keyToFilename key+            catchIOError+                (do+                    status <- getFileStatus filename+                    body <- withFile filename ReadMode readValue+                    return $ Just body+                )+                (ignoreNonexisting Nothing)+        , cachePut = \key val -> do+            let filename = keyToFilename key+            withFile filename WriteMode (\h -> writeValue h val)+        , cacheDelete = \key -> do+            let filename = keyToFilename key+            removeFile filename `catchIOError` ignoreNonexisting_+        , cacheVacuum = do+            filenames <- map (cacheDir </>) . filter (".cache" `isSuffixOf`) <$> getDirectoryContents cacheDir+            timestamped <- forM filenames $ \filename -> do+                status <- getFileStatus filename+                let ts = realToFrac $ modificationTime status+                return (filename, ts)+            now <- getPOSIXTime+            let expirationTS = now - maxAge+                expired = map fst . filter (\(_, ts) -> ts < expirationTS) $ timestamped+            forM_ expired $ \filename ->+                removeFile filename+                `catchIOError` ignoreNonexisting_+            return $ length expired+        }+    where+        keyToFilename key = cacheDir </> encodeFilename (serializeKey key) <> ".cache"+        keyFromFilename = deserializeKey . decodeFilename . takeFileName++encodeFilename :: String -> FilePath+encodeFilename =+    concatMap encodeChar+    where+        encodeChar :: Char -> FilePath+        encodeChar c+            | isAsciiLower c ||+              isAsciiUpper c ||+              isDigit c = [c]+            | otherwise = '_' : show (ord c)++decodeFilename :: FilePath -> String+decodeFilename "" = ""+decodeFilename ('_':xs) =+    let (intpart, remainder) = span isDigit xs+    in chr (read intpart):decodeFilename remainder+decodeFilename ('.':xs) = ""+decodeFilename (x:xs)+    | isAlpha x = x:decodeFilename xs+    | otherwise = decodeFilename xs
+ src/Web/Sprinkles/Cache/Memcached.hs view
@@ -0,0 +1,31 @@+{-#LANGUAGE NoImplicitPrelude #-}+{-#LANGUAGE ScopedTypeVariables #-}+{-#LANGUAGE OverloadedStrings #-}+module Web.Sprinkles.Cache.Memcached+where++import ClassyPrelude+import Web.Sprinkles.Cache+import Data.Time.Clock.POSIX+import qualified Data.HashMap.Strict as HashMap+import Data.Default+import qualified Database.Memcached.Binary.Maybe as Memcached++memcachedCache :: IO (Cache ByteString ByteString)+memcachedCache = do+    let connectInfo :: Memcached.ConnectInfo = def+        withConnection = Memcached.withConnection connectInfo+        expiry = 60+    return+        Cache+            { cacheGet = \key -> do+                lazyVal <- withConnection $ Memcached.get_ key+                return $ toStrict <$> lazyVal+            , cachePut = \key val -> do+                withConnection $ Memcached.set 0 expiry key (fromStrict val)+                return ()+            , cacheDelete = \key -> do+                withConnection $ Memcached.delete key+                return ()+            , cacheVacuum = return 0+            }
+ src/Web/Sprinkles/Cache/Memory.hs view
@@ -0,0 +1,31 @@+{-#LANGUAGE NoImplicitPrelude #-}+{-#LANGUAGE ScopedTypeVariables #-}+module Web.Sprinkles.Cache.Memory+where++import ClassyPrelude+import Web.Sprinkles.Cache+import Data.Time.Clock.POSIX+import qualified Data.HashMap.Strict as HashMap++memCache :: forall k v. (Hashable k, Eq k) => POSIXTime -> IO (Cache k v)+memCache maxAge = do+    cacheVar <- newMVar (mapFromList [] :: HashMap k (v, POSIXTime))+    return+        Cache+            { cacheGet = \key ->+                fmap fst . lookup key <$> readMVar cacheVar+            , cachePut = \key val -> do+                ts <- getPOSIXTime+                modifyMVar_ cacheVar $ return . insertMap key (val, ts)+            , cacheDelete = \key ->+                modifyMVar_ cacheVar $ return . deleteMap key+            , cacheVacuum = do+                now <- getPOSIXTime+                let threshold = now - maxAge+                modifyMVar cacheVar $ \m -> do+                    let m' = HashMap.filter (\(_, ts) -> ts > threshold) m+                        sizeBefore = HashMap.size m+                        sizeAfter = HashMap.size m'+                    return (m', sizeBefore - sizeAfter)+            }
+ src/Web/Sprinkles/Databases.hs view
@@ -0,0 +1,146 @@+{-#LANGUAGE NoImplicitPrelude #-}+{-#LANGUAGE OverloadedStrings #-}+{-#LANGUAGE TypeFamilies #-}+{-#LANGUAGE MultiParamTypeClasses #-}+{-#LANGUAGE FlexibleInstances #-}+{-#LANGUAGE FlexibleContexts #-}+{-#LANGUAGE LambdaCase #-}+{-#LANGUAGE DeriveGeneric #-}++module Web.Sprinkles.Databases+where++import ClassyPrelude+import Data.Aeson as JSON+import Data.Aeson.TH as JSON+import qualified Database.HDBC as HDBC+import Database.HDBC.PostgreSQL (connectPostgreSQL)+import Database.HDBC.Sqlite3 (connectSqlite3)+import Database.HDBC.MySQL (connectMySQL, MySQLConnectInfo (..))+import qualified Data.Serialize as Cereal+import Data.Serialize (Serialize)++data DSN = DSN { dsnDriver :: SqlDriver, dsnDetails :: Text }+    deriving (Show, Generic)++type instance Element DSN = Text++instance MonoFunctor DSN where+    omap f (DSN driver details) = DSN driver (f details)++data SqlDriver = SqliteDriver+               | PostgreSQLDriver+               | MySQLDriver+               deriving (Show, Generic)++instance Serialize SqlDriver where+    put SqliteDriver = Cereal.put ("sqlt" :: String)+    put PostgreSQLDriver = Cereal.put ("pg" :: String)+    put MySQLDriver = Cereal.put ("my" :: String)+    get = do+        str <- Cereal.get+        case str :: String of+            "sqlt" -> return SqliteDriver+            "pg" -> return PostgreSQLDriver+            "my" -> return MySQLDriver+            x -> fail $ "Invalid database driver: " <> show x++sqlDriverID :: SqlDriver -> Text+sqlDriverID SqliteDriver = "sqlite"+sqlDriverID PostgreSQLDriver = "postgres"+sqlDriverID MySQLDriver = "mysql"++sqlDriverFromID :: Text -> Maybe SqlDriver+sqlDriverFromID "sqlite" = Just SqliteDriver+sqlDriverFromID "sqlite3" = Just SqliteDriver+sqlDriverFromID "pg" = Just PostgreSQLDriver+sqlDriverFromID "pgsql" = Just PostgreSQLDriver+sqlDriverFromID "postgres" = Just PostgreSQLDriver+sqlDriverFromID "postgresql" = Just PostgreSQLDriver+sqlDriverFromID "my" = Just MySQLDriver+sqlDriverFromID "mysql" = Just MySQLDriver+sqlDriverFromID _ = Nothing++instance ToJSON SqlDriver where+    toJSON = toJSON . sqlDriverID++instance FromJSON SqlDriver where+    parseJSON x =+        parseJSON x >>=+            maybe (fail "Invalid SQL Driver") return . sqlDriverFromID++instance Serialize DSN where+    put (DSN driver details) = do+        Cereal.put driver+        Cereal.put (unpack details)+    get = DSN <$> Cereal.get <*> (pack <$> Cereal.get)++dsnToText :: DSN -> Text+dsnToText (DSN driver details) = sqlDriverID driver <> ":" <> details++instance FromJSON DSN where+    parseJSON (Object obj) = do+        driver <- obj .: "driver"+        details <- obj .: "dsn"+        return $ DSN driver details+    parseJSON _ = fail "Invalid DSN"++withConnection :: DSN -> (HDBC.ConnWrapper -> IO a) -> IO a+withConnection dsn inner = do+    conn <- connect dsn+    inner conn+    +connect :: DSN -> IO HDBC.ConnWrapper+connect (DSN driver details) =+    case driver of+        SqliteDriver -> HDBC.ConnWrapper <$> connectSqlite3 (unpack details)+        PostgreSQLDriver -> HDBC.ConnWrapper <$> connectPostgreSQL (unpack details)+        MySQLDriver -> do+            info <- parseMysqlConnectInfo details+            HDBC.ConnWrapper <$> connectMySQL info++parseMysqlConnectInfo :: Monad m => Text -> m MySQLConnectInfo+parseMysqlConnectInfo details = do+    MySQLConnectInfo+        <$> getStrDef "localhost" "host"+        <*> getStrDef "" "user"+        <*> getStrDef "" "password"+        <*> getStrDef "" "database"+        <*> getIntDef 3306 "port"+        <*> getStrDef "" "socket"+        <*> getStr "group"+    where+        getStr :: Monad m => Text -> m (Maybe String)+        getStr key =+            maybe+                (return Nothing)+                (fmap Just . parseStr)+                (lookup key dict)++        getStrDef :: Monad m => String -> Text -> m String+        getStrDef d = fmap (fromMaybe d) . getStr++        getInt :: Monad m => Text -> m (Maybe Int)+        getInt key =+            maybe+                (return Nothing)+                (fmap Just . parseInt)+                (lookup key dict)++        getIntDef :: Monad m => Int -> Text -> m Int+        getIntDef d = fmap (fromMaybe d) . getInt++        dict :: HashMap Text Text+        dict = mapFromList . catMaybes . map parsePair . splitElem ';' $ details++        parsePair :: Text -> Maybe (Text, Text)+        parsePair src =+            case break (== '=') src of+                (key, "") -> Nothing+                (key, value) -> Just (toLower key, drop 1 value)++        parseStr :: Monad m => Text -> m String+        parseStr = return . unpack++        parseInt :: Monad m => Text -> m Int+        parseInt = maybe (fail "Invalid number") return . readMay
+ src/Web/Sprinkles/Exceptions.hs view
@@ -0,0 +1,124 @@+{-#LANGUAGE NoImplicitPrelude #-}+{-#LANGUAGE OverloadedStrings #-}+{-#LANGUAGE DeriveGeneric #-}++module Web.Sprinkles.Exceptions+( formatException+, GingerFunctionCallException (..)+, InvalidReaderException (..)+, TemplateNotFoundException (..)+, handleUncaughtExceptions+, withSourceContext+, overrideSourceContext+)+where++import ClassyPrelude+import Control.Exception+import qualified Database.HDBC as HDBC+import Database.HDBC (SqlError (..))+import GHC.Generics+import Text.Pandoc.Error (PandocError (..))+import qualified Data.Yaml as YAML+import Text.Ginger as Ginger++-- * Various exception types for specific situations++data GingerFunctionCallException =+    GingerInvalidFunctionArgs+        { invalidFunctionName :: Text+        , invalidFunctionExpectedArgs :: Text+        }+    deriving (Show, Eq, Generic)++instance Exception GingerFunctionCallException++data InvalidReaderException =+    InvalidReaderException+        { invalidReaderName :: Text+        , invalidReaderMessage :: Text+        }+    deriving (Show, Eq, Generic)++instance Exception InvalidReaderException++throwInvalidReaderException :: String -> String -> IO ()+throwInvalidReaderException name msg =+    throwM $ InvalidReaderException (pack name) (pack msg)++data TemplateNotFoundException = TemplateNotFoundException Text+    deriving (Show, Eq, Generic)++instance Exception TemplateNotFoundException++data SourceContextException =+    WithSourceContext { sourceContext ::  Text, withoutSourceContext :: SomeException }+    deriving (Show, Generic)++instance Exception SourceContextException where++class HasSourceContext a where+    overrideSourceContext :: Text -> a -> a++instance HasSourceContext SourceContextException where+    overrideSourceContext = \source e ->+        WithSourceContext source (withoutSourceContext e)++instance HasSourceContext Ginger.ParserError where+    overrideSourceContext = \s e -> e { peSourceName = Just . unpack $ s }++withSourceContext :: Exception e => Text -> e -> SomeException+withSourceContext context =+    toException . WithSourceContext context . toException++-- * Exception formatting++formatException :: SomeException -> Text+formatException e =+    fromMaybe (tshow e) . foldr (<|>) Nothing $ map ($ e) formatters++formatters :: [SomeException -> Maybe Text]+formatters =+    [ fmap formatSqlError . fromException+    , fmap formatIOError . fromException+    , fmap formatYamlParseException . fromException+    , fmap formatTemplateNotFoundException . fromException+    , fmap formatWithSourceContext . fromException+    , fmap formatGingerFunctionCallException . fromException+    , fmap formatGingerParserError . fromException+    ]++formatSqlError :: SqlError -> Text+formatSqlError (SqlError { seErrorMsg = msg }) =+    "SQL Error: " <> pack msg++formatIOError :: IOException -> Text+formatIOError e =+    tshow e++formatGingerFunctionCallException :: GingerFunctionCallException -> Text+formatGingerFunctionCallException e =+    "Invalid arguments to function '" <> invalidFunctionName e <> "', expected " <> invalidFunctionExpectedArgs e++formatGingerParserError :: Ginger.ParserError -> Text+formatGingerParserError e =+    "line " <> (fromMaybe "?" . fmap tshow . Ginger.peSourceLine $ e)+    <> ", column " <> (fromMaybe "?" . fmap tshow . Ginger.peSourceColumn $ e)+    <> ": " <> pack (Ginger.peErrorMessage e)++formatYamlParseException :: YAML.ParseException -> Text+formatYamlParseException = pack . YAML.prettyPrintParseException++formatTemplateNotFoundException :: TemplateNotFoundException -> Text+formatTemplateNotFoundException (TemplateNotFoundException templateName) =+    "Template not found: " <> templateName++formatWithSourceContext :: SourceContextException -> Text+formatWithSourceContext (WithSourceContext context inner) =+    "In '" <> context <> "': " <> formatException inner++-- * Handling exceptions++handleUncaughtExceptions :: SomeException -> IO ()+handleUncaughtExceptions e =+    hPutStrLn stderr . formatException $ e
+ src/Web/Sprinkles/Handlers.hs view
@@ -0,0 +1,20 @@+{-#LANGUAGE NoImplicitPrelude #-}+module Web.Sprinkles.Handlers+( handleStaticTarget+, handleJSONTarget+, handleRedirectTarget+, handleTemplateTarget+, handleNotFound+, handleMethodNotAllowed+, handle404+, handle405+, handle500+)+where++import ClassyPrelude+import Web.Sprinkles.Handlers.Common+import Web.Sprinkles.Handlers.Static+import Web.Sprinkles.Handlers.Redirect+import Web.Sprinkles.Handlers.JSON+import Web.Sprinkles.Handlers.Template
+ src/Web/Sprinkles/Handlers/Common.hs view
@@ -0,0 +1,142 @@+{-#LANGUAGE NoImplicitPrelude #-}+{-#LANGUAGE OverloadedStrings #-}+{-#LANGUAGE OverloadedLists #-}+{-#LANGUAGE LambdaCase #-}+{-#LANGUAGE ScopedTypeVariables #-}+{-#LANGUAGE FlexibleInstances #-}+{-#LANGUAGE FlexibleContexts #-}+{-#LANGUAGE MultiParamTypeClasses #-}+module Web.Sprinkles.Handlers.Common+where++import ClassyPrelude+import Web.Sprinkles.Exceptions+import Web.Sprinkles.Backends+import qualified Network.Wai as Wai+import Web.Sprinkles.Logger as Logger+import Web.Sprinkles.Project+import Web.Sprinkles.ProjectConfig+import Network.HTTP.Types+       (Status, status200, status302, status400, status404, status405, status500)+import Web.Sprinkles.Handlers.Respond+import Text.Ginger.Html (Html, htmlSource)+import Web.Sprinkles.Backends.Loader.Type+       (PostBodySource (..), pbsFromRequest, pbsInvalid)+import Web.Sprinkles.Rule (expandReplacementBackend)+import Data.AList (AList)+import qualified Data.AList as AList+import Text.Ginger (GVal, ToGVal (..), Run, marshalGVal)+import Control.Monad.Writer (Writer)++data NotFoundException = NotFoundException+    deriving (Show)++instance Exception NotFoundException where++data MethodNotAllowedException = MethodNotAllowedException+    deriving (Show)++instance Exception MethodNotAllowedException where++type ContextualHandler =+    HashMap Text (Items (BackendData IO Html)) ->+    Project ->+    Wai.Application++handleNotFound :: Project -> Wai.Request -> (Wai.Response -> IO Wai.ResponseReceived) -> NotFoundException -> IO Wai.ResponseReceived+handleNotFound project request respond _ = do+    handle404+        project+        request+        respond++handleMethodNotAllowed :: Project -> Wai.Request -> (Wai.Response -> IO Wai.ResponseReceived) -> MethodNotAllowedException -> IO Wai.ResponseReceived+handleMethodNotAllowed project request respond _ = do+    handle405+        project+        request+        respond++handleHttpError :: Status+                -> Text+                -> Text+                -> Project+                -> Wai.Application+handleHttpError status templateName message project request respond =+    respondNormally `catch` handleTemplateNotFound+    where+        cache = projectBackendCache project+        backendPaths = pcContextData . projectConfig $ project+        logger = projectLogger project+        respondNormally = do+            backendData <- loadBackendDict+                                (writeLog logger)+                                (pbsFromRequest request)+                                cache+                                backendPaths+                                (setFromList [])+                                (mapFromList [])+            respondTemplateHtml+                project+                status+                templateName+                backendData+                request+                respond+        handleTemplateNotFound (e :: TemplateNotFoundException) = do+            writeLog logger Logger.Warning $ "Template " ++ templateName ++ " not found, using built-in fallback"+            let headers = [("Content-type", "text/plain;charset=utf8")]+            respond . Wai.responseLBS status headers . fromStrict . encodeUtf8 $ message++handle404 :: Project+          -> Wai.Application+handle404 = handleHttpError status404 "404.html" "Not Found"++handle405 :: Project+          -> Wai.Application+handle405 = handleHttpError status405 "405.html" "Method Not Allowed"++handle500 :: SomeException+          -> Project+          -> Wai.Application+handle500 err project request respond = do+    writeLog (projectLogger project) Logger.Error $ formatException err+    handleHttpError status500 "500.html" message project request respond+    where+        message = "Something went pear-shaped. The problem seems to be on our side."++loadBackendDict :: (LogLevel -> Text -> IO ())+                -> PostBodySource+                -> RawBackendCache+                -> AList Text BackendSpec+                -> Set Text+                -> HashMap Text (GVal (Run (Writer Text) Text))+                -> IO (HashMap Text (Items (BackendData IO Html)))+loadBackendDict writeLog postBodySrc cache backendPaths required globalContext = do+    mapFromList <$> go globalContext (AList.toList backendPaths)+    where+        go :: HashMap Text (GVal (Run (Writer Text) Text))+           -> [(Text, BackendSpec)]+           -> IO [(Text, Items (BackendData IO Html))]+        go _ [] = return []+        go context ((key, backendSpec):specs) = do+            let expBackendSpec = (expandReplacementBackend context backendSpec)+            bd :: Items (BackendData IO Html)+               <- loadBackendData+                    writeLog+                    postBodySrc+                    cache+                    expBackendSpec+            resultItem <- case bd of+                NotFound ->+                    if key `elem` required+                        then throwM NotFoundException+                        else return (key, NotFound)+                _ -> return (key, bd)+            let bdG :: GVal (Run IO Html)+                bdG = toGVal bd+                bdGP :: GVal (Run (Writer Text) Text)+                bdGP = marshalGVal bdG+                context' = insertMap key bdGP context+            remainder <- go context' specs+            return $ resultItem:remainder
+ src/Web/Sprinkles/Handlers/JSON.hs view
@@ -0,0 +1,41 @@+{-#LANGUAGE NoImplicitPrelude #-}+{-#LANGUAGE OverloadedStrings #-}+{-#LANGUAGE OverloadedLists #-}+{-#LANGUAGE LambdaCase #-}+{-#LANGUAGE ScopedTypeVariables #-}+{-#LANGUAGE FlexibleInstances #-}+{-#LANGUAGE FlexibleContexts #-}+{-#LANGUAGE MultiParamTypeClasses #-}+module Web.Sprinkles.Handlers.JSON+( handleJSONTarget+)+where++import ClassyPrelude+import Web.Sprinkles.Backends+import qualified Network.Wai as Wai+import Web.Sprinkles.Logger as Logger+import Web.Sprinkles.Project+import Web.Sprinkles.ProjectConfig+import Web.Sprinkles.Handlers.Common+import Network.HTTP.Types+       (Status, status200, status302, status400, status404, status500)+import Web.Sprinkles.Backends.Loader.Type+       (PostBodySource (..), pbsFromRequest, pbsInvalid)+import Data.Aeson as JSON+import Data.Aeson.Encode.Pretty as JSON+import Data.Aeson.TH as JSON+import Data.AList (AList)+import qualified Data.AList as AList++handleJSONTarget :: ContextualHandler+handleJSONTarget backendData+                 project+                 request+                 respond = do+    respond $ Wai.responseLBS+        status200+        [("Content-type", "application/json")]+        (JSON.encode backendData)++
+ src/Web/Sprinkles/Handlers/Redirect.hs view
@@ -0,0 +1,39 @@+{-#LANGUAGE NoImplicitPrelude #-}+{-#LANGUAGE OverloadedStrings #-}+{-#LANGUAGE OverloadedLists #-}+{-#LANGUAGE LambdaCase #-}+{-#LANGUAGE ScopedTypeVariables #-}+{-#LANGUAGE FlexibleInstances #-}+{-#LANGUAGE FlexibleContexts #-}+{-#LANGUAGE MultiParamTypeClasses #-}+module Web.Sprinkles.Handlers.Redirect+( handleRedirectTarget+)+where++import ClassyPrelude+import Web.Sprinkles.Backends+import qualified Network.Wai as Wai+import Web.Sprinkles.Logger as Logger+import Web.Sprinkles.Project+import Web.Sprinkles.ProjectConfig+import Web.Sprinkles.Handlers.Common+import Network.HTTP.Types+       (Status, status200, status302, status400, status404, status500)+import Web.Sprinkles.Backends.Loader.Type+       (PostBodySource (..), pbsFromRequest, pbsInvalid)+import qualified Data.ByteString.Lazy.UTF8 as LUTF8+import qualified Data.ByteString.UTF8 as UTF8+import Data.AList (AList)++handleRedirectTarget :: Text -> ContextualHandler+handleRedirectTarget redirectPath+                     backendData+                     project+                     request+                     respond =+    respond $ Wai.responseLBS+        status302+        [("Location", UTF8.fromString . unpack $ redirectPath)]+        ""+
+ src/Web/Sprinkles/Handlers/Respond.hs view
@@ -0,0 +1,246 @@+{-#LANGUAGE DeriveGeneric #-}+{-#LANGUAGE NoImplicitPrelude #-}+{-#LANGUAGE OverloadedStrings #-}+{-#LANGUAGE OverloadedLists #-}+{-#LANGUAGE LambdaCase #-}+{-#LANGUAGE ScopedTypeVariables #-}+{-#LANGUAGE FlexibleInstances #-}+{-#LANGUAGE FlexibleContexts #-}+{-#LANGUAGE MultiParamTypeClasses #-}+module Web.Sprinkles.Handlers.Respond+( respondTemplateHtml+, respondTemplateText+)+where++import ClassyPrelude+import Web.Sprinkles.Backends+import qualified Network.Wai as Wai+import Web.Sprinkles.Logger as Logger+import Web.Sprinkles.Project+import Web.Sprinkles.ProjectConfig+import Web.Sprinkles.Exceptions++import Text.Ginger+       (parseGinger, Template, runGingerT, GingerContext, GVal(..), ToGVal(..),+        (~>))+import qualified Text.Ginger as Ginger+import Text.Ginger.Html (Html, htmlSource)++import qualified Data.ByteString.UTF8 as UTF8+import qualified Data.ByteString.Lazy.UTF8 as LUTF8+import Data.ByteString.Builder (stringUtf8)+import qualified Data.Yaml as YAML+import qualified Data.Aeson as JSON+import qualified Data.Aeson.Encode.Pretty as JSON+import Data.Default (Default, def)+import Data.Text (Text)+import qualified Data.Text as Text+import System.Locale.Read (getLocale)+import qualified Text.Pandoc as Pandoc+import qualified Text.Pandoc.Readers.Creole as Pandoc+import qualified Data.CaseInsensitive as CI++import Network.HTTP.Types+       (Status, status200, status302, status400, status404, status500)+import Network.HTTP.Types.URI (queryToQueryText)++import Web.Sprinkles.Backends.Loader.Type+       (PostBodySource (..), pbsFromRequest, pbsInvalid)++instance ToGVal m ByteString where+    toGVal = toGVal . UTF8.toString++instance ToGVal m (CI.CI ByteString) where+    toGVal = toGVal . CI.original++instance ToGVal m Wai.Request where+    toGVal rq =+        Ginger.orderedDict+            [ "httpVersion" ~> tshow (Wai.httpVersion rq)+            , "method" ~> decodeUtf8 (Wai.requestMethod rq)+            , "path" ~> decodeUtf8 (Wai.rawPathInfo rq)+            , "query" ~> decodeUtf8 (Wai.rawQueryString rq)+            , "pathInfo" ~> Wai.pathInfo rq+            , ( "queryInfo"+              , Ginger.orderedDict+                    [ (key, toGVal val)+                    | (key, val)+                    <- queryToQueryText (Wai.queryString rq)+                    ]+              )+            , ( "headers"+              , Ginger.orderedDict+                    [ (decodeCI n, toGVal $ decodeUtf8 v)+                    | (n, v)+                    <- Wai.requestHeaders rq+                    ]+              )+            ]++decodeCI :: CI.CI ByteString -> Text+decodeCI = decodeUtf8 . CI.original++respondTemplateHtml :: ToGVal (Ginger.Run IO Html) a+                    => Project+                    -> Status+                    -> Text+                    -> HashMap Text a+                    -> Wai.Application+respondTemplateHtml project+                    status+                    templateName+                    contextMap+                    request+                    respond = do+    let contentType = "text/html;charset=utf8"+        contextLookup = mkContextLookup request project contextMap+        headers = [("Content-type", contentType)]+    template <- getTemplate project templateName+    respond . Wai.responseStream status headers $ \write flush -> do+        let writeHtml = write . stringUtf8 . unpack . htmlSource+            context :: GingerContext IO Html+            context = Ginger.makeContextHtmlM contextLookup writeHtml+        runGingerT context template+        flush++respondTemplateText :: ToGVal (Ginger.Run IO Text) a+                    => Project+                    -> Status+                    -> Text+                    -> HashMap Text a+                    -> Wai.Application+respondTemplateText project+                    status+                    templateName+                    contextMap+                    request+                    respond = do+    let contentType = "text/plain;charset=utf8"+        contextLookup = mkContextLookup request project contextMap+        headers = [("Content-type", contentType)]+    template <- getTemplate project templateName+    respond . Wai.responseStream status headers $ \write flush -> do+        let writeText = write . stringUtf8 . unpack+            context :: GingerContext IO Text+            context = Ginger.makeContextTextM contextLookup writeText+        runGingerT context template+        flush++mkContextLookup :: (ToGVal (Ginger.Run IO h) a)+                => Wai.Request+                -> Project+                -> HashMap Text a+                -> Text+                -> Ginger.Run IO h (GVal (Ginger.Run IO h))+mkContextLookup request project contextMap key = do+    let cache = projectBackendCache project+        logger = projectLogger project+        contextMap' =+            fmap toGVal contextMap <>+            mapFromList+                [ "request" ~> request+                , ("load", Ginger.fromFunction (gfnLoadBackendData (writeLog logger) cache))+                , ("ellipse", Ginger.fromFunction gfnEllipse)+                , ("json", Ginger.fromFunction gfnJSON)+                , ("yaml", Ginger.fromFunction gfnYAML)+                , ("getlocale", Ginger.fromFunction (gfnGetLocale (writeLog logger)))+                , ("pandoc", Ginger.fromFunction (gfnPandoc (writeLog logger)))+                , ("markdown", Ginger.fromFunction (gfnPandocAlias "markdown" (writeLog logger)))+                , ("textile", Ginger.fromFunction (gfnPandocAlias "textile" (writeLog logger)))+                , ("rst", Ginger.fromFunction (gfnPandocAlias "rst" (writeLog logger)))+                , ("creole", Ginger.fromFunction (gfnPandocAlias "creole" (writeLog logger)))+                ]+    return . fromMaybe def $ lookup key contextMap'++gfnLoadBackendData :: forall h. (LogLevel -> Text -> IO ()) -> RawBackendCache -> Ginger.Function (Ginger.Run IO h)+gfnLoadBackendData writeLog cache args =+    Ginger.dict <$> forM (zip [0..] args) loadPair+    where+        loadPair :: (Int, (Maybe Text, GVal (Ginger.Run IO h)))+                 -> Ginger.Run IO h (Text, GVal (Ginger.Run IO h))+        loadPair (index, (keyMay, gBackendURL)) = do+            let backendURL = Ginger.asText gBackendURL+            backendData :: Items (BackendData IO h) <- liftIO $+                loadBackendData writeLog pbsInvalid cache =<< parseBackendURI backendURL+            return+                ( fromMaybe (tshow index) keyMay+                , toGVal backendData+                )++catchToGinger :: forall h m. (LogLevel -> Text -> IO ())+              -> IO (GVal m)+              -> IO (GVal m)+catchToGinger writeLog action =+    action+        `catch` (\(e :: SomeException) -> do+            writeLog Logger.Error . formatException $ e+            return . toGVal $ False+        )++gfnPandoc :: forall h. (LogLevel -> Text -> IO ()) -> Ginger.Function (Ginger.Run IO h)+gfnPandoc writeLog args = liftIO . catchToGinger writeLog $+    case Ginger.extractArgsDefL [("src", ""), ("reader", "markdown")] args of+        Right [src, readerName] -> toGVal <$> pandoc (Ginger.asText readerName) (Ginger.asText src)+        _ -> throwM $ GingerInvalidFunctionArgs "pandoc" "string src, string reader"++gfnPandocAlias :: forall h. Text -> (LogLevel -> Text -> IO ()) -> Ginger.Function (Ginger.Run IO h)+gfnPandocAlias readerName writeLog args = liftIO . catchToGinger writeLog $+    case Ginger.extractArgsDefL [("src", "")] args of+        Right [src] -> toGVal <$> pandoc readerName (Ginger.asText src)+        _ -> throwM $ GingerInvalidFunctionArgs "pandoc" "string src, string reader"++pandoc :: Text -> Text -> IO Pandoc.Pandoc+pandoc readerName src = do+    reader <- either+        (\err -> fail $ "Invalid reader: " ++ show err)+        return+        (getReader $ unpack readerName)+    let read = case reader of+            Pandoc.StringReader r -> r Pandoc.def . unpack+            Pandoc.ByteStringReader r -> fmap (fmap fst) . r Pandoc.def . encodeUtf8+    read (fromStrict src) >>= either+        (\err -> fail $ "Reading " ++ show readerName ++ " failed: " ++ show err)+        return+    where+        getReader "creole" = Right $ Pandoc.mkStringReader Pandoc.readCreole+        getReader readerName = Pandoc.getReader readerName++gfnGetLocale :: forall h. (LogLevel -> Text -> IO ()) -> Ginger.Function (Ginger.Run IO h)+gfnGetLocale writeLog args = liftIO . catchToGinger writeLog $+    case Ginger.extractArgsDefL [("category", "LC_TIME"), ("locale", "")] args of+        Right [gCat, gName] ->+            case (Ginger.asText gCat, Text.unpack . Ginger.asText $ gName) of+                ("LC_TIME", "") -> toGVal <$> getLocale Nothing+                ("LC_TIME", localeName) -> toGVal <$> getLocale (Just localeName)+                (cat, localeName) -> return def -- valid call, but category not implemented+        _ -> throwM $ GingerInvalidFunctionArgs "getlocale" "string category, string name"++gfnEllipse :: Ginger.Function (Ginger.Run IO h)+gfnEllipse [] = return def+gfnEllipse [(Nothing, str)] =+    gfnEllipse [(Nothing, str), (Nothing, toGVal (100 :: Int))]+gfnEllipse [(Nothing, str), (Nothing, len)] = do+    let txt = Ginger.asText str+        actualLen = ClassyPrelude.length txt+        targetLen = fromMaybe 100 $ ceiling <$> Ginger.asNumber len+        txt' = if actualLen + 3 > targetLen+                    then take (targetLen - 3) txt <> "..."+                    else txt+    return . toGVal $ txt'+gfnEllipse ((Nothing, str):xs) = do+    let len = fromMaybe (toGVal (100 :: Int)) $ lookup (Just "len") xs+    gfnEllipse [(Nothing, str), (Nothing, len)]+gfnEllipse xs = do+    let str = fromMaybe def $ lookup (Just "str") xs+    gfnEllipse $ (Nothing, str):xs++gfnJSON :: Ginger.Function (Ginger.Run IO h)+gfnJSON [] = return def+gfnJSON ((_, x):xs) =+    return . toGVal . LUTF8.toString . JSON.encodePretty $ x++gfnYAML :: Ginger.Function (Ginger.Run IO h)+gfnYAML [] = return def+gfnYAML ((_, x):xs) =+    return . toGVal . UTF8.toString . YAML.encode $ x
+ src/Web/Sprinkles/Handlers/Static.hs view
@@ -0,0 +1,94 @@+{-#LANGUAGE NoImplicitPrelude #-}+{-#LANGUAGE OverloadedStrings #-}+{-#LANGUAGE LambdaCase #-}+{-#LANGUAGE ScopedTypeVariables #-}+{-#LANGUAGE FlexibleInstances #-}+{-#LANGUAGE FlexibleContexts #-}+{-#LANGUAGE MultiParamTypeClasses #-}+module Web.Sprinkles.Handlers.Static+( handleStaticTarget+)+where++import ClassyPrelude+import Web.Sprinkles.Backends+import qualified Network.Wai as Wai+import Web.Sprinkles.Logger as Logger+import Web.Sprinkles.Project+import Web.Sprinkles.ProjectConfig+import Web.Sprinkles.Handlers.Common+import Network.HTTP.Types+       (Status, status200, status206, status302, status400, status404, status500)+import Web.Sprinkles.Backends.Loader.Type+       (PostBodySource (..), pbsFromRequest, pbsInvalid)+import Web.Sprinkles.Backends.Data+       (RawBytes (..))+import Data.AList (AList)+import qualified Data.AList as AList+import Data.Char (isSpace)+import Text.Read (readMaybe)+import qualified Data.Text as Text+import Text.Printf (printf)++handleStaticTarget :: Maybe Text -> ContextualHandler+handleStaticTarget childPathMay+                   backendData+                   project+                   request+                   respond = do+    backendItemBase <- case lookup "file" backendData of+        Nothing -> throwM NotFoundException+        Just NotFound -> throwM NotFoundException+        Just (SingleItem item) -> return item+        Just (MultiItem []) -> throwM NotFoundException+        Just (MultiItem (x:xs)) -> return x+    backendItem <- case childPathMay of+        Nothing -> return backendItemBase+        Just path -> case lookup path (bdChildren backendItemBase) of+            Nothing -> throwM NotFoundException+            Just item -> return item+    let responseRangeMay = do+            requestRangeHeader <- lookup "Range" $ Wai.requestHeaders request+            parseRequestRangeHeader $ decodeUtf8 requestRangeHeader+    case responseRangeMay of+        Nothing -> do+            responseBytes <- rawToLBS (bdRaw backendItem)+            respond $ Wai.responseLBS+                status200+                    [ ("Content-type", bmMimeType . bdMeta $ backendItem)+                    , ("Accept-ranges", "bytes")+                    ]+                responseBytes+        Just (from, to) -> do+            responseLength <- rbLength . bdRaw $ backendItem+            let from' = (min from responseLength)+                to' = (min to responseLength)+                rangeHeaderValue = encodeUtf8 . Text.pack $+                    printf "%d-%d/%d"+                        from'+                        to'+                        responseLength+            responseBytes <- rbGetRange (bdRaw backendItem) from' to'+            respond $ Wai.responseLBS+                status206+                    [ ("Content-type", bmMimeType . bdMeta $ backendItem)+                    , ("Accept-ranges", "bytes")+                    , ("Range", rangeHeaderValue)+                    ]+                responseBytes+++parseRequestRangeHeader :: Text -> Maybe (Integer, Integer)+parseRequestRangeHeader src = do+    let src' :: Text+        src' = filter (not . isSpace) src+    when (not $ "bytes=" `isPrefixOf` src')+        Nothing+    let src'' :: Text+        src'' = drop (length ("bytes=" :: Text)) src'+    case Text.splitOn "-" src'' of+        [fromStr, toStr] -> do+            from <- readMaybe $ Text.unpack fromStr+            to <- readMaybe $ Text.unpack toStr+            return (from, to)+        _ -> Nothing
+ src/Web/Sprinkles/Handlers/Template.hs view
@@ -0,0 +1,41 @@+{-#LANGUAGE NoImplicitPrelude #-}+{-#LANGUAGE OverloadedStrings #-}+{-#LANGUAGE OverloadedLists #-}+{-#LANGUAGE LambdaCase #-}+{-#LANGUAGE ScopedTypeVariables #-}+{-#LANGUAGE FlexibleInstances #-}+{-#LANGUAGE FlexibleContexts #-}+{-#LANGUAGE MultiParamTypeClasses #-}+module Web.Sprinkles.Handlers.Template+( handleTemplateTarget+)+where++import ClassyPrelude+import Web.Sprinkles.Backends+import qualified Network.Wai as Wai+import Web.Sprinkles.Logger as Logger+import Web.Sprinkles.Project+import Web.Sprinkles.ProjectConfig+import Web.Sprinkles.Handlers.Common+import Web.Sprinkles.Handlers.Respond+import Network.HTTP.Types+       (Status, status200, status302, status400, status404, status500)+import Web.Sprinkles.Backends.Loader.Type+       (PostBodySource (..), pbsFromRequest, pbsInvalid)+import Data.AList (AList)+import qualified Data.AList as AList++handleTemplateTarget :: Text -> ContextualHandler+handleTemplateTarget templateName+                     backendData+                     project+                     request+                     respond =+    respondTemplateHtml+        project+        status200+        templateName+        backendData+        request+        respond
+ src/Web/Sprinkles/Logger.hs view
@@ -0,0 +1,131 @@+{-#LANGUAGE NoImplicitPrelude #-}+{-#LANGUAGE DeriveGeneric #-}+{-#LANGUAGE OverloadedStrings #-}+module Web.Sprinkles.Logger+( stderrLogger+, newBufferedLogger+, syslogLogger+, nullLogger+, tChanLogger+, Logger (..)+, LogLevel (..)+, LogMessage (..)+, writeLog+)+where++import ClassyPrelude+import Control.Concurrent (forkIO)+import Data.Aeson (FromJSON (..), Value (..), (.:))+import qualified System.Posix.Syslog as Syslog+import Data.Default (Default (..))++data LogLevel = Debug+              | Notice+              | Warning+              | Error+              | Critical+              deriving (Show, Eq, Ord, Enum, Bounded, Generic)++logLevelToSyslogPrio :: LogLevel -> Syslog.Priority+logLevelToSyslogPrio Debug = Syslog.Debug+logLevelToSyslogPrio Notice = Syslog.Notice+logLevelToSyslogPrio Warning = Syslog.Warning+logLevelToSyslogPrio Error = Syslog.Error+logLevelToSyslogPrio Critical = Syslog.Critical++instance FromJSON LogLevel where+    parseJSON (String "debug") = return Debug+    parseJSON (String "notice") = return Notice+    parseJSON (String "warning") = return Warning+    parseJSON (String "error") = return Error+    parseJSON (String "critical") = return Critical+    parseJSON x = fail $ "Invalid log level: " <> show x++data LogMessage =+    LogMessage+        { lmTimestamp :: !UTCTime+        , lmLevel :: !LogLevel+        , lmMessage :: !Text+        }+        deriving (Show, Eq)++instance FromJSON LogMessage where+    parseJSON (Object o) =+        LogMessage <$> o .: "timestamp"+                   <*> o .: "level"+                   <*> o .: "message"++writeLog :: Logger -> LogLevel -> Text -> IO ()+writeLog logger level message = do+    now <- getCurrentTime+    writeLogMessage logger $+        LogMessage now level message++formatMessage :: LogMessage -> Text+formatMessage msg =+    tshow (lmTimestamp msg) <>+    " [" <>+    tshow (lmLevel msg) <>+    "] " <>+    lmMessage msg++data Logger =+    Logger+        { writeLogMessage :: LogMessage -> IO ()+        }++instance Default Logger where+    def = nullLogger++nullLogger :: Logger+nullLogger = Logger+    { writeLogMessage = const . return $ ()+    }++-- | A plain logger that logs directly to stdout. Since there is no buffer,+-- having multiple threads write to this logger can cause unexpected behavior.+stderrLogger :: LogLevel -> Logger+stderrLogger level =+    def { writeLogMessage = go }+    where+        go msg =+            when+                (lmLevel msg >= level)+                (hPutStrLn stderr $ formatMessage msg)++-- | A plain logger that logs to syslog.+syslogLogger :: LogLevel -> Logger+syslogLogger level =+    def { writeLogMessage = go }+    where+        go msg =+            Syslog.withSyslog+                "sprinkles"+                []+                Syslog.USER+                (Syslog.logUpTo $ logLevelToSyslogPrio level) $+                    Syslog.syslog+                        (logLevelToSyslogPrio . lmLevel $ msg)+                        (unpack . lmMessage $ msg)++-- | A logger that wraps another logger and adds line buffering.+newBufferedLogger :: Logger -> IO Logger+newBufferedLogger inner = do+    channel <- newChan+    let writeFn = writeChan channel+    forkIO . forever $+        -- TODO: This thread will currently keep running until the main+        -- program exits. OK for now, but it would be cleaner to provide a+        -- cleanup function that can be used in a bracket.+        readChan channel >>= writeLogMessage inner+    return $ Logger writeFn++-- | A logger that writes to a 'TChan'. This implementation is for+-- simulation-testing purposes; it is not possible to construct such+-- a logger declaratively through configuration files, and it would+-- be nonsensical anyway, because the main application does not provide+-- any suitable TChans, nor any way of reading them out.+tChanLogger :: TChan LogMessage -> Logger+tChanLogger chan =+    Logger (atomically . writeTChan chan)
+ src/Web/Sprinkles/MatchedText.hs view
@@ -0,0 +1,32 @@+{-#LANGUAGE NoImplicitPrelude #-}+{-#LANGUAGE FlexibleInstances #-}+{-#LANGUAGE MultiParamTypeClasses #-}+{-#LANGUAGE AutoDeriveTypeable #-}+{-#LANGUAGE DeriveGeneric #-}+{-#LANGUAGE OverloadedStrings #-}+module Web.Sprinkles.MatchedText+where++import ClassyPrelude++import qualified Text.Ginger as Ginger+import Text.Ginger+       (parseGinger, Template, runGingerT, GingerContext, GVal(..), ToGVal(..),+        (~>))+import GHC.Generics+import qualified Data.Text as Text++data MatchedText =+    MatchedText Text |+    MatchedTexts [Text]+    deriving (Show, Read, Eq, Generic)++instance ToGVal m MatchedText where+    toGVal (MatchedText t) = toGVal t+    toGVal (MatchedTexts ts) =+        (toGVal ts) {+            Ginger.asText = Text.intercalate "/" ts+        }++instance IsString MatchedText where+    fromString = MatchedText . fromString
+ src/Web/Sprinkles/PandocGVal.hs view
@@ -0,0 +1,370 @@+{-#LANGUAGE NoImplicitPrelude #-}+{-#LANGUAGE OverloadedStrings #-}+{-#LANGUAGE LambdaCase #-}+{-#LANGUAGE FlexibleInstances #-}+{-#LANGUAGE MultiParamTypeClasses #-}+{-#LANGUAGE ScopedTypeVariables #-}+module Web.Sprinkles.PandocGVal+where++import ClassyPrelude hiding (asText, asList)+import Text.Ginger as Ginger (GVal (..), ToGVal (..), dict, (~>))+import Text.Ginger.Html (unsafeRawHtml)+import qualified Text.Ginger as Ginger+import qualified Text.Ginger.Run.VM as Ginger+import Text.Pandoc+import Text.Pandoc.Walk (query, walk)+import Data.Default (def)+import Data.Aeson (ToJSON (..))+import Data.Scientific (fromFloatDigits)++writerOptions :: WriterOptions+writerOptions =+    def { writerStandalone = False+        , writerHtml5 = True+        }++gfnWithMediaRoot :: Monad m => Pandoc -> Ginger.Function (Ginger.Run m h)+gfnWithMediaRoot pandoc args = do+    defMediaroot <- fromMaybe def . Ginger.lookupKey "path" <$> Ginger.getVar "request"+    let extracted =+            Ginger.extractArgsDefL+                [ ("mediaroot", defMediaroot)+                ]+                args+    case extracted of+        Right [mediaroot] -> do+            let pandoc' = relativeUrlPrefix (unpack $ asText mediaroot) pandoc+            return $ toGVal pandoc'+        _ -> return def++gfnWithAppRoot :: Monad m => Pandoc -> Ginger.Function (Ginger.Run m h)+gfnWithAppRoot pandoc args = do+    defApproot <- Ginger.getVar "approot"+    let extracted =+            Ginger.extractArgsDefL+                [ ("approot", defApproot)+                ]+                args+    case extracted of+        Right [approot] -> do+            let pandoc' = localUrlPrefix (unpack $ asText approot) pandoc+            return $ toGVal pandoc'+        _ -> return def++prefixRelativeUrl :: String -> String -> String+prefixRelativeUrl prefix url+    | "http://" `isPrefixOf` url = url+    | "https://" `isPrefixOf` url = url+    | "/" `isPrefixOf` url = url+    | ":" `isPrefixOf` url = url+    | otherwise = prefix ++ "/" ++ url++prefixLocalUrl :: String -> String -> String+prefixLocalUrl prefix url+    | "http://" `isPrefixOf` url = url+    | "https://" `isPrefixOf` url = url+    | ":" `isPrefixOf` url = url+    | "/" `isPrefixOf` url = prefix ++ url+    | otherwise = url++modifyUrls :: (String -> String) -> Pandoc -> Pandoc+modifyUrls f = walk goInline+    where+        goInline :: Inline -> Inline+        goInline (Image attrs inlines (url, title)) =+            Image attrs (map goInline inlines) (f url, title)+        goInline (Link attrs inlines (url, title)) =+            Link attrs (map goInline inlines) (f url, title)+        goInline x = x++localUrlPrefix :: String -> Pandoc -> Pandoc+localUrlPrefix prefix = modifyUrls (prefixLocalUrl prefix)++relativeUrlPrefix :: String -> Pandoc -> Pandoc+relativeUrlPrefix prefix = modifyUrls (prefixRelativeUrl prefix)++instance Monad m => ToGVal (Ginger.Run m h) Pandoc where+    toGVal pandoc@(Pandoc meta blocks) =+        def { asList = Just $ map toGVal blocks+            , asDictItems =+                Just+                    [ ( "meta", toGVal meta )+                    , ( "body", toGVal blocks )+                    , ( "withAppRoot"+                      , Ginger.fromFunction . gfnWithAppRoot $ pandoc+                      )+                    , ( "withMediaRoot"+                      , Ginger.fromFunction . gfnWithMediaRoot $ pandoc+                      )+                    ]+            , asLookup = Just $ \case+                            "meta" -> Just (toGVal meta)+                            "body" -> Just (toGVal blocks)+                            "withMediaRoot" -> Just . Ginger.fromFunction . gfnWithMediaRoot $ pandoc+                            "withAppRoot" -> Just . Ginger.fromFunction . gfnWithAppRoot $ pandoc+                            _ -> Nothing+            , asHtml = unsafeRawHtml . pack . writeHtmlString writerOptions $ pandoc+            , asText = unwords . fmap (asText . toGVal) $ blocks+            , asBoolean = True+            , asNumber = Nothing+            , asFunction = Nothing+            , Ginger.length = Just (ClassyPrelude.length blocks)+            , isNull = False+            }++instance ToGVal m Meta where+    toGVal meta =+        let entries :: [(String, MetaValue)]+            entries = mapToList . unMeta $ meta+        in dict [ pack key ~> value | (key, value) <- entries ]++instance ToGVal m MetaValue where+    toGVal (MetaMap m) = dict [ pack key ~> value | (key, value) <- mapToList m ]+    toGVal (MetaList values) = toGVal values+    toGVal (MetaBool b) = toGVal b+    toGVal (MetaString str) = toGVal str+    toGVal (MetaInlines inlines) = toGVal inlines+    toGVal (MetaBlocks blocks) = toGVal blocks++instance ToGVal m Block where+    toGVal block =+        let pandoc = Pandoc nullMeta [block]+            listItems :: [GVal m]+            blockProps :: HashMap Text (GVal m)+            (blockProps, listItems) = blockChildren block+            baseProps = mapFromList ["children" ~> listItems]+            props = baseProps <> blockProps+        in def { asList = Just listItems+               , asDictItems = Just $ mapToList props+               , asLookup = Just $ \key -> lookup key props+               , asHtml = unsafeRawHtml . pack . writeHtmlString writerOptions $ pandoc+               , asText = unwords . fmap ((<> " ") . asText) $ listItems+               , asBoolean = True+               , asNumber = Nothing+               , asFunction = Nothing+               , Ginger.length = Just (ClassyPrelude.length listItems)+               , isNull = False+               }++blockProperties :: forall m. Block -> HashMap Text (GVal m)+blockProperties = fst . blockChildren+blockItems :: forall m. Block -> [GVal m]+blockItems = snd . blockChildren++blockChildren :: forall m. Block -> (HashMap Text (GVal m), [GVal m])+blockChildren (Plain items) =+    ( mapFromList ["type" ~> ("plain" :: Text)]+    , fmap toGVal items+    )+blockChildren (Para items) =+    ( mapFromList ["type" ~> ("p" :: Text)]+    , fmap toGVal items+    )+blockChildren (CodeBlock (id, classes, attrs) items) =+    ( mapFromList+        [ "type" ~> ("code" :: Text)+        , "id" ~> (pack id :: Text)+        , "classes" ~> (fmap pack classes :: [Text])+        , ("attrs", dict [ pack t ~> v | (t, v) <- attrs ])+        ]+    , fmap toGVal items+    )+blockChildren (RawBlock (Format fmt) items) =+    ( mapFromList+        [ "type" ~> ("raw" :: Text)+        , "format" ~> fmt+        ]+    , fmap toGVal items+    )+blockChildren (BlockQuote items) =+    ( mapFromList ["type" ~> ("blockquote" :: Text)]+    , fmap toGVal items+    )+blockChildren (OrderedList _ items) =+    ( mapFromList+        [ "type" ~> ("ol" :: Text)+        , "items" ~> items+        ]+    , fmap toGVal items+    )+blockChildren (BulletList items) =+    ( mapFromList+        [ "type" ~> ("ul" :: Text)+        , "items" ~> items+        ]+    , fmap toGVal items+    )+blockChildren (DefinitionList pairs) =+    ( mapFromList+        [ "type" ~> ("dl" :: Text)+        , "items" ~>+            [ mapFromList [ "dt" ~> dt, "dd" ~> dd ] :: HashMap Text (GVal m)+            | (dt, dd) <- pairs+            ]+        ]+    , fmap toGVal pairs+    )+blockChildren (Header level (id, classes, attrs) items) =+    ( mapFromList+        [ "type" ~> ("h" <> tshow level :: Text)+        , "id" ~> (pack id :: Text)+        , "classes" ~> (fmap pack classes :: [Text])+        , ("attrs", dict [ pack t ~> v | (t, v) <- attrs ])+        ]+    , fmap toGVal items+    )+blockChildren HorizontalRule =+    ( mapFromList ["type" ~> ("hr" :: Text)]+    , []+    )+blockChildren (Table caption alignments widths headers rows) =+    ( mapFromList+        [ "type" ~> ("table" :: Text)+        , "caption" ~> caption+        , "columns" ~>+            [ mapFromList+                [ "align" ~> alignment+                , "width" ~> fromFloatDigits width+                , "header" ~> header+                ] :: HashMap Text (GVal m)+            | (alignment, width, header)+            <- zip3 alignments widths headers+            ]+        , "rows" ~> rows+        ]+    , fmap toGVal rows :: [GVal m]+    )+blockChildren (Div (id, classes, attrs) items) =+    ( mapFromList+        [ "type" ~> ("div" :: Text)+        , "id" ~> (pack id :: Text)+        , "classes" ~> (fmap pack classes :: [Text])+        , ("attrs", dict [ pack t ~> v | (t, v) <- attrs ])+        ]+    , fmap toGVal items+    )+blockChildren Null = (mapFromList [], [])++instance ToGVal m Alignment where+    toGVal AlignLeft = toGVal ("left" :: Text)+    toGVal AlignRight = toGVal ("right" :: Text)+    toGVal AlignCenter = toGVal ("center" :: Text)+    toGVal AlignDefault = def++instance ToGVal m Inline where+    toGVal inline =+        let pandoc = Pandoc nullMeta [Plain [inline]]+            listItems :: [GVal m]+            inlineProps :: HashMap Text (GVal m)+            (inlineProps, listItems) = inlineChildren inline+            baseProps = mapFromList ["children" ~> listItems]+            props = baseProps <> inlineProps+        in def { asList = Just listItems+               , asDictItems = Just $ mapToList props+               , asLookup = Just $ \key -> lookup key props+               , asHtml = unsafeRawHtml . pack . writeHtmlString writerOptions $ pandoc+               , asText = unwords . fmap asText $ listItems+               , asBoolean = True+               , asNumber = Nothing+               , asFunction = Nothing+               , Ginger.length = Just (ClassyPrelude.length listItems)+               , isNull = False+               }++inlineChildren :: forall m. Inline -> (HashMap Text (GVal m), [GVal m])+inlineChildren (Str str) =+    ( mapFromList ["type" ~> ("str" :: Text)]+    , [toGVal . (pack :: String -> Text) $ str] :: [GVal m]+    )+inlineChildren (Emph items) =+    ( mapFromList ["type" ~> ("em" :: Text)]+    , fmap toGVal items+    )+inlineChildren (Strong items) =+    ( mapFromList ["type" ~> ("strong" :: Text)]+    , fmap toGVal items+    )+inlineChildren (Strikeout items) =+    ( mapFromList ["type" ~> ("strikeout" :: Text)]+    , fmap toGVal items+    )+inlineChildren (Superscript items) =+    ( mapFromList ["type" ~> ("superscript" :: Text)]+    , fmap toGVal items+    )+inlineChildren (Subscript items) =+    ( mapFromList ["type" ~> ("subscript" :: Text)]+    , fmap toGVal items+    )+inlineChildren (SmallCaps items) =+    ( mapFromList ["type" ~> ("smallCaps" :: Text)]+    , fmap toGVal items+    )+inlineChildren (Quoted quoteType items) =+    ( mapFromList ["type" ~> ("quoted" :: Text)]+    , fmap toGVal items+    )+inlineChildren (Cite citations items) =+    ( mapFromList+        [ "type" ~> ("cite" :: Text)+        , "citations" ~> citations+        ]+    , fmap toGVal items+    )+inlineChildren (Code (id, classes, attrs) code) =+    ( mapFromList+        [ "type" ~> ("code" :: Text)+        , "id" ~> (pack id :: Text)+        , "classes" ~> (fmap pack classes :: [Text])+        , "attrs" ~> attrs+        , ("attrs", dict [ pack t ~> v | (t, v) <- attrs ])+        ]+    , [toGVal (pack code :: Text)]+    )+inlineChildren Space = (mapFromList ["type" ~> ("space" :: Text)], [toGVal (" " :: Text)])+inlineChildren SoftBreak = (mapFromList ["type" ~> ("sbr" :: Text)], [toGVal (" " :: Text)])+inlineChildren LineBreak = (mapFromList ["type" ~> ("br" :: Text)], [toGVal (" " :: Text)])+inlineChildren (Math mathType src) = (mapFromList ["type" ~> ("math" :: Text)], [toGVal (pack src:: Text)])+inlineChildren (RawInline fmt src) = (mapFromList ["type" ~> ("rawInline" :: Text)], [toGVal (pack src:: Text)])+inlineChildren (Link (id, classes, attrs) items target) =+    ( mapFromList+        [ "type" ~> ("link" :: Text)+        , "id" ~> (pack id :: Text)+        , "classes" ~> (fmap pack classes :: [Text])+        , ("attrs", dict [ pack t ~> v | (t, v) <- attrs ])+        ]+    , fmap toGVal items+    )+inlineChildren (Image (id, classes, attrs) items target) =+    ( mapFromList+        [ "type" ~> ("image" :: Text)+        , "id" ~> (pack id :: Text)+        , "classes" ~> (fmap pack classes :: [Text])+        , ("attrs", dict [ pack t ~> v | (t, v) <- attrs ])+        ]+    , fmap toGVal items+    )+inlineChildren (Note items) = (mapFromList ["type" ~> ("note" :: Text)], fmap toGVal items)+inlineChildren (Span (id, classes, attrs) items) =+    ( mapFromList+        [ "type" ~> ("span" :: Text)+        , "id" ~> (pack id :: Text)+        , "classes" ~> (fmap pack classes :: [Text])+        , ("attrs", dict [ pack t ~> v | (t, v) <- attrs ])+        ]+    , fmap toGVal items+    )++instance ToGVal m Citation where+    toGVal c =+        dict [ "id" ~> citationId c+             , "prefix" ~> citationPrefix c+             , "suffix" ~> citationSuffix c+             , "mode" ~> citationMode c+             , "noteNum" ~> citationNoteNum c+             , "hash" ~> citationHash c+             ]++instance ToGVal m CitationMode where+    toGVal = toGVal . show
+ src/Web/Sprinkles/Pattern.hs view
@@ -0,0 +1,208 @@+{-#LANGUAGE NoImplicitPrelude #-}+{-#LANGUAGE OverloadedStrings #-}+{-#LANGUAGE LambdaCase #-}+{-#LANGUAGE ScopedTypeVariables #-}+{-#LANGUAGE FlexibleInstances #-}+{-#LANGUAGE MultiParamTypeClasses #-}+{-#LANGUAGE TupleSections #-}+module Web.Sprinkles.Pattern+where++import ClassyPrelude hiding ( (<|>) )+import Text.Parsec as Parsec+import qualified Data.Text as Text+import Data.Aeson as JSON+import Data.Aeson.TH as JSON+import Text.Regex.PCRE.String as RE+import Text.Regex.Base as RE+import qualified Data.Array as Array+import Control.MaybeEitherMonad+import System.IO.Unsafe (unsafePerformIO)+import Web.Sprinkles.MatchedText+++data BasePatternItem =+    Exactly Text |+    Regex String RE.CompOption |+    Any+    deriving (Eq, Show)++data PatternPathItem =+    PatternPathItem+        { patternItemName :: Maybe Text+        , patternItemBase :: BasePatternItem+        , patternItemMatchMany :: MatchMulti+        }+    deriving (Eq, Show)++data MatchMulti = MatchOne | MatchMany+    deriving (Eq, Show, Enum, Bounded)++data PatternQueryItem =+    PatternQueryItem+        { patternQItemName :: Maybe Text+        , patternQItemKey :: Text+        , patternQItemValueBase :: BasePatternItem+        , patternQItemRequired :: Bool+        }+    deriving (Eq, Show)++data Pattern = Pattern [PatternPathItem] [PatternQueryItem]+    deriving (Eq, Show)++instance FromJSON Pattern where+    parseJSON val = (either error return . parsePattern) =<< parseJSON val++parsePattern :: Text -> Either String Pattern+parsePattern input =+    onLeft (\pe -> unpack input ++ "\n" ++ show pe) $+    runParser patternP () "" input++onLeft :: (a -> c) -> Either a b -> Either c b+onLeft f (Left x) = Left $ f x+onLeft _ (Right x) = Right x++patternP :: Parsec Text () Pattern+patternP = Pattern <$> patternPath <*> option [] patternQueryP++patternPath =+    some (Parsec.try patternPathItemP)+    <|> (string "/" >> return [])++patternPathItemP :: Parsec Text () PatternPathItem+patternPathItemP = do+    char '/'+    namedPathItemP <|> anonymousAnyP <|> anonymousLiteralP++patternQueryP :: Parsec Text () [PatternQueryItem]+patternQueryP = do+    char '?'+    patternQueryItemP `sepBy` char '&'++patternQueryItemP :: Parsec Text () PatternQueryItem+patternQueryItemP = do+    key <- pack <$> Parsec.many (noneOf ['=', '&'])+    char '='+    (nameMay, val) <- namedQueryItemP <|> fmap (Nothing,) baseItemP+    required <- option True $ char '?' *> return False+    return $ PatternQueryItem nameMay key val required++doubleBraced :: Parsec Text () a -> Parsec Text () a+doubleBraced inner =+    string "{{" *> inner <* string "}}"++nameP :: Parsec Text () Text+nameP = fmap pack . some $ alphaNum <|> oneOf "_-"++namedPathItemP :: Parsec Text () PatternPathItem+namedPathItemP = doubleBraced $ do+    name <- optionMaybe $ nameP <* char ':'+    base <- baseItemP+    multi <- multiModifierP+    return $ PatternPathItem name base multi++multiModifierP :: Parsec Text () MatchMulti+multiModifierP = (char '*' >> return MatchMany) <|> return MatchOne++namedQueryItemP :: Parsec Text () (Maybe Text, BasePatternItem)+namedQueryItemP = doubleBraced $ do+    name <- optionMaybe $ nameP <* char ':'+    base <- baseItemP+    return (name, base)++baseItemP :: Parsec Text () BasePatternItem+baseItemP = regexP <|> anyP <|> literalP++anyP :: Parsec Text () BasePatternItem+anyP = char '*' *> return Any++literalP :: Parsec Text () BasePatternItem+literalP = Exactly . pack <$> some (noneOf ['{', '}', '*', '/', '?', '&', '='])++regexP :: Parsec Text () BasePatternItem+regexP = do+    char '/'+    body <- Parsec.many regexCharP+    char '/'+    options <- sum <$> Parsec.many regexOptionP+    return $ Regex body options++regexCharP :: Parsec Text () Char+regexCharP = (char '\\' >> char '/') <|> noneOf "/"++regexOptionP :: Parsec Text () RE.CompOption+regexOptionP = (char 'm' >> return RE.compMultiline)+             <|> (char 'e' >> return RE.compExtended)+             <|> (char 'u' >> return RE.compUTF8)++anonymousLiteralP :: Parsec Text () PatternPathItem+anonymousLiteralP = PatternPathItem Nothing <$> literalP <*> multiModifierP++anonymousAnyP :: Parsec Text () PatternPathItem+anonymousAnyP = PatternPathItem Nothing <$> anyP <*> multiModifierP++matchPattern :: Pattern -> [Text] -> [(Text, Maybe Text)] -> Maybe (HashMap Text MatchedText)+matchPattern (Pattern pathItems queryItems) path query = do+    pathMatches <- matchPatternPath pathItems path+    queryMatches <- fmap MatchedText <$> matchPatternQuery queryItems query+    return $ pathMatches <> queryMatches++matchPatternPath :: [PatternPathItem] -> [Text] -> Maybe (HashMap Text MatchedText)+matchPatternPath [] []= Just (mapFromList [])+matchPatternPath [] _ = Nothing+matchPatternPath (x:xs) query = do+    (nameMay, value, remainder) <- matchPatternPathItem x query+    rest <- matchPatternPath xs remainder+    return $ case nameMay of+        Nothing -> rest+        Just name -> insertMap name value rest++matchPatternPathItem :: PatternPathItem -> [Text] -> Maybe (Maybe Text, MatchedText, [Text])+matchPatternPathItem (PatternPathItem nameMay base MatchOne) [] = Nothing+matchPatternPathItem (PatternPathItem nameMay base MatchOne) (query:remainder) = do+    value <- matchBaseItem base query+    return (nameMay, MatchedText value, remainder)+matchPatternPathItem (PatternPathItem nameMay base MatchMany) query = do+    let (values, remainder) = matchBaseItemMulti base query+    return (nameMay, MatchedTexts values, remainder)++matchPatternQuery :: [PatternQueryItem] -> [(Text, Maybe Text)] -> Maybe (HashMap Text Text)+matchPatternQuery items q = matchPatternQuery' items (fromMaybe "" <$> mapFromList q)++matchPatternQuery' :: [PatternQueryItem] -> HashMap Text Text -> Maybe (HashMap Text Text)+matchPatternQuery' [] _ = Just (mapFromList [])+matchPatternQuery' (x:xs) query = do+    (nameMay, value, remainder) <- matchPatternQueryItem x query+    rest <- matchPatternQuery' xs remainder+    return $ case nameMay of+        Nothing -> rest+        Just name -> insertMap name value rest++matchPatternQueryItem :: PatternQueryItem -> HashMap Text Text -> Maybe (Maybe Text, Text, HashMap Text Text)+matchPatternQueryItem (PatternQueryItem nameMay key valP required) query = do+    candidateValue <- lookup key query+    value <- matchBaseItem valP candidateValue+    return (nameMay, value, deleteMap key query)++matchBaseItemMulti :: BasePatternItem -> [Text] -> ([Text], [Text])+matchBaseItemMulti pitem [] = ([], [])+matchBaseItemMulti pitem (q:remainder) =+    case matchBaseItem pitem q of+        Nothing -> ([], remainder)+        Just value ->+            let (values, remainder') = matchBaseItemMulti pitem remainder+            in (value:values, remainder')++matchBaseItem :: BasePatternItem -> Text -> Maybe Text+matchBaseItem (Exactly t) x =+    if t == x+        then Just t+        else Nothing+matchBaseItem Any x = Just x+matchBaseItem (Regex body options) q = unsafePerformIO $ do+    re <- RE.compile options RE.execAnchored body >>= eitherFail+    matches <- RE.execute re (unpack q) >>= eitherFail+    case Array.elems <$> matches of+        Just ((offset, length):_) ->+            return . Just . take length . drop offset $ q+        _ -> return Nothing
+ src/Web/Sprinkles/Project.hs view
@@ -0,0 +1,138 @@+{-#LANGUAGE DeriveGeneric #-}+{-#LANGUAGE NoImplicitPrelude #-}+{-#LANGUAGE OverloadedStrings #-}+{-#LANGUAGE OverloadedLists #-}+{-#LANGUAGE LambdaCase #-}+module Web.Sprinkles.Project+where++import ClassyPrelude+import Data.Aeson as JSON+import Text.Ginger+        ( parseGinger+        , Template+        , runGingerT+        , GingerContext+        , GVal (..)+        , ToGVal (..)+        , (~>)+        )+import Text.Ginger.Html (Html, htmlSource)+import qualified Text.Ginger as Ginger+import System.Directory (makeAbsolute, doesDirectoryExist, doesFileExist, getDirectoryContents)+import System.FilePath+import Data.Time.Clock.POSIX (POSIXTime)++import Web.Sprinkles.Exceptions+import Web.Sprinkles.Rule+import Web.Sprinkles.ProjectConfig+import Web.Sprinkles.ServerConfig+import Web.Sprinkles.Logger+import Web.Sprinkles.Cache+import Web.Sprinkles.Cache.Filesystem (filesystemCache)+import Web.Sprinkles.Cache.Memory (memCache)+import Web.Sprinkles.Cache.Memcached (memcachedCache)++newtype TemplateCache = TemplateCache (HashMap Text Template)++data Project =+    Project+        { projectConfig :: ProjectConfig+        , projectTemplates :: TemplateCache+        , projectBackendCache :: Cache ByteString ByteString+        , projectLogger :: Logger+        }++loadProject :: ServerConfig -> FilePath -> IO Project+loadProject sconfig dir = do+    pconfig <- loadProjectConfig dir+    logger <- createLogger $ fromMaybe (StdioLog Warning) (scLogger sconfig)+    templates <- preloadTemplates logger dir+    caches <- sequence $ fmap (createCache dir) (scBackendCache sconfig)+    let cache = mconcat caches+    return $ Project pconfig templates cache logger+++createLogger :: LoggerConfig -> IO Logger+createLogger DiscardLog =+    return nullLogger+createLogger (Syslog level) =+    return $ syslogLogger level+createLogger (StdioLog level) =+    newBufferedLogger (stderrLogger level)++createCache :: FilePath -> BackendCacheConfig -> IO (Cache ByteString ByteString)+createCache cwd (FilesystemCache dir expiration) =+    return $ filesystemCache+        (unpack . decodeUtf8) -- "serialize" key+        (encodeUtf8 . pack) -- "unserialize" key+        hPut -- write value+        hGetContents -- read value+        (cwd </> dir)+        expiration+createCache _ (MemCache expiration) = memCache expiration+createCache _ MemcachedCache = memcachedCache++enumerateFiles :: FilePath -> IO [FilePath]+enumerateFiles dir = map (dir </>) <$> getDirectoryContents dir++findFiles :: (FilePath -> IO Bool) -> FilePath -> IO [FilePath]+findFiles p dir = enumerateFiles dir >>= filterM p++findFilesR :: (FilePath -> IO Bool) -> FilePath -> IO [FilePath]+findFilesR p dir = do+    localFiles <- findFiles p dir+    subdirs <- findFiles isInterestingSubdir dir+    childFiles <- concat <$> mapM (findFilesR p) subdirs+    return $ localFiles ++ childFiles+    where+        isInterestingSubdir :: FilePath -> IO Bool+        isInterestingSubdir dirname = do+            isDir <- doesDirectoryExist dirname+            return $ isDir && not (isHiddenFile dirname)++isHiddenFile :: FilePath -> Bool+isHiddenFile = ("." `isPrefixOf`) . takeFileName++isTemplateFile :: FilePath -> IO Bool+isTemplateFile fp = do+    isFile <- doesFileExist fp+    let isHidden = "." `isPrefixOf` (takeBaseName fp)+    return $ not isHidden && isFile++preloadTemplates :: Logger -> FilePath -> IO TemplateCache+preloadTemplates logger dir = do+    prefix <- makeAbsolute $ dir </> "templates"+    allFilenames <- findFilesR isTemplateFile prefix+    filenames <- findFiles isTemplateFile prefix+    templateSources <- forM allFilenames readFile+    let templateSourceMap :: HashMap String String+        templateSourceMap =+            mapFromList $+                zip+                    (map (makeRelative prefix) allFilenames)+                    templateSources+        resolver :: String -> IO (Maybe String)+        resolver name =+            let name' = makeRelative prefix . normalise $ prefix </> name+            in return $ lookup name' templateSourceMap+    let relativeFilenames = map (makeRelative prefix) filenames+    templates <- forM relativeFilenames $ \filename -> do+        source <- maybe+                    (throwM . TemplateNotFoundException . pack $ filename)+                    return+                    (lookup filename templateSourceMap)+        parseGinger resolver (Just filename) source >>= \case+            Left err -> throwM $ withSourceContext (pack filename) err+            Right t -> return t+    return . TemplateCache . mapFromList $ zip (map pack relativeFilenames) templates++getTemplate :: Project -> Text -> IO Template+getTemplate project templateName = do+    let TemplateCache tm = projectTemplates project+    maybe+        (throwM $ TemplateNotFoundException templateName)+        return+        (lookup templateName tm)++
+ src/Web/Sprinkles/ProjectConfig.hs view
@@ -0,0 +1,70 @@+{-#LANGUAGE NoImplicitPrelude #-}+{-#LANGUAGE OverloadedStrings #-}+{-#LANGUAGE OverloadedLists #-}+{-#LANGUAGE LambdaCase #-}+module Web.Sprinkles.ProjectConfig+where++import ClassyPrelude+import Web.Sprinkles.Rule+import Data.Aeson as JSON+import Data.Aeson.TH+import qualified Data.Yaml as YAML+import Web.Sprinkles.Backends+import Data.Default+import System.FilePath.Glob (glob)+import System.Environment (getEnv, lookupEnv)+import Control.MaybeEitherMonad (maybeFail)+import Data.AList (AList)+import qualified Data.AList as AList+import Web.Sprinkles.Exceptions++data ProjectConfig =+    ProjectConfig+        { pcContextData :: AList Text BackendSpec+        , pcRules :: [Rule]+        }+        deriving (Show)++instance Default ProjectConfig where+    def = ProjectConfig+            { pcContextData = AList.empty+            , pcRules = []+            }++instance Monoid ProjectConfig where+    mempty = def+    mappend = pcAppend++instance FromJSON ProjectConfig where+    parseJSON (Object obj) = do+        contextData <- fromMaybe AList.empty <$> obj .:? "data"+        rulesValue <- fromMaybe (toJSON ([] :: [Value])) <$> (obj .:? "rules" <|> obj .:? "Rules")+        rules <- parseJSON rulesValue+        return ProjectConfig+            { pcContextData = contextData+            , pcRules = rules+            }++pcAppend :: ProjectConfig -> ProjectConfig -> ProjectConfig+pcAppend a b =+    ProjectConfig+        { pcContextData = pcContextData a <> pcContextData b+        , pcRules = pcRules a <> pcRules b+        }++firstNonNull :: [a] -> [a] -> [a]+firstNonNull [] xs = xs+firstNonNull xs _ = xs++loadProjectConfigFile :: FilePath -> IO ProjectConfig+loadProjectConfigFile fn =+    YAML.decodeFileEither fn >>=+        either+            (throwM . withSourceContext (pack fn))+            return++loadProjectConfig :: FilePath -> IO ProjectConfig+loadProjectConfig dir =+    loadProjectConfigFile $ dir </> "project.yml"+
+ src/Web/Sprinkles/Replacement.hs view
@@ -0,0 +1,61 @@+{-#LANGUAGE NoImplicitPrelude #-}+{-#LANGUAGE OverloadedStrings #-}+{-#LANGUAGE LambdaCase #-}+{-#LANGUAGE ScopedTypeVariables #-}+{-#LANGUAGE FlexibleInstances #-}+{-#LANGUAGE MultiParamTypeClasses #-}+module Web.Sprinkles.Replacement+( Replacement+, expandReplacement+, expandReplacementText+)+where++import ClassyPrelude+import Data.Aeson as JSON+import Data.Aeson.TH as JSON+import Text.Ginger ( Template+                   , runGinger+                   , parseGinger+                   , makeContextText+                   , ToGVal+                   , toGVal+                   , GVal (..)+                   , Run+                   )+import qualified Text.Ginger as Ginger+import Data.Default+import Control.Monad.Writer (Writer)+import Web.Sprinkles.Exceptions (formatException)++data ReplacementItem =+    Literal Text |+    Variable Text+    deriving (Show, Eq)++newtype Replacement = Replacement Template+    deriving (Show)++instance FromJSON Replacement where+    parseJSON val = (either (fail . unpack . formatException) return . parseReplacement) =<< parseJSON val++expandReplacementText :: HashMap Text (GVal (Run (Writer Text) Text))+                      -> Text+                      -> Either SomeException Text+expandReplacementText variables input =+    expandReplacement variables <$> parseReplacement input++parseReplacement :: Text -> Either SomeException Replacement+parseReplacement input =+    either (Left . toException) (Right . Replacement) . runIdentity $+    parseGinger+        (const $ return Nothing)+        Nothing+        (unpack input)++expandReplacement :: HashMap Text (GVal (Run (Writer Text) Text)) -> Replacement -> Text+expandReplacement variables (Replacement template) =+    runGinger context template+    where+        context = makeContextText lookupFn+        lookupFn varName = fromMaybe def $ lookup varName variables
+ src/Web/Sprinkles/Rule.hs view
@@ -0,0 +1,164 @@+{-#LANGUAGE NoImplicitPrelude #-}+{-#LANGUAGE OverloadedStrings #-}+{-#LANGUAGE OverloadedLists #-}+{-#LANGUAGE ScopedTypeVariables #-}+{-#LANGUAGE LambdaCase #-}+module Web.Sprinkles.Rule+where++import ClassyPrelude+import Web.Sprinkles.Pattern+import Web.Sprinkles.Replacement+import Web.Sprinkles.Backends+import Web.Sprinkles.MatchedText+import Data.Aeson as JSON+import Control.MaybeEitherMonad+import Network.HTTP.Types.URI (QueryText)+import qualified Network.HTTP as HTTP+import qualified Network.HTTP.Types as HTTP+import qualified Data.AList as AList+import Data.AList (AList)+import Text.Ginger (Run, ToGVal (..), GVal)+import Control.Monad.Writer (Writer)+import qualified Data.Set as Set++data RuleTarget p =+    TemplateTarget p |+    RedirectTarget p |+    StaticTarget (Maybe p) |+    JSONTarget+    deriving (Eq, Show)++type Seconds = Integer++data ClientCacheSetting =+    NoCache |+    CacheForever |+    MaxAge Seconds+    deriving (Eq, Show)++instance FromJSON ClientCacheSetting where+    parseJSON = \case+        String "no-cache" -> return NoCache+        String "forever" -> return CacheForever+        String x -> fail $ "Invalid cache expiry: " ++ show x+        Number n -> return $ MaxAge (floor n)++data Rule =+    Rule+        { ruleRoutePattern :: Pattern+        , ruleContextData :: AList Text BackendSpec+        , ruleTarget :: RuleTarget Replacement+        , ruleRequired :: Set Text+        , ruleAcceptedMethods :: Set HTTP.Method+        , ruleCaching :: ClientCacheSetting+        , ruleContentTypeOverride :: Maybe ByteString+        }+        deriving (Show)++orElse :: Monad m => m (Maybe a) -> m (Maybe a) -> m (Maybe a)+orElse leftAction rightAction = do+    leftAction >>= maybe rightAction (return . Just)+++instance FromJSON Rule where+    parseJSON (Object obj) = do+        pattern <- obj .: "pattern"+        (methodsMay :: Maybe [Text]) <- obj .:? "methods"+        (methodMay :: Maybe [Text]) <- fmap (:[]) <$> (obj .:? "method")+        let methods = Set.fromList . map encodeUtf8 . fromMaybe [ "GET", "POST" ] $+                methodsMay <|> methodMay+        contextData <- fromMaybe AList.empty <$> obj .:? "data"+        templateMay <- fmap TemplateTarget <$> (obj .:? "template")+        redirectMay <- fmap RedirectTarget <$> (obj .:? "redirect")+        static <- fromMaybe False <$> (obj .:? "static")+        staticChildPath <- obj .:? "child"+        let target =+                if static+                    then StaticTarget staticChildPath+                    else (fromMaybe JSONTarget $ redirectMay <|> templateMay)+        required <- obj .:? "required" .!= []+        caching <- obj .:? "cache" .!= CacheForever+        contentTypeOverride <-+            (fmap encodeUtf8) <$>+                (obj .:? "content-type")+        return $ Rule+            pattern+            contextData+            target+            required+            methods+            caching+            contentTypeOverride+    parseJSON x = fail $ "Expected rule, but found " <> show x++expandRuleTarget :: HashMap Text (GVal (Run (Writer Text) Text)) -> RuleTarget Replacement -> RuleTarget Text+expandRuleTarget _ JSONTarget = JSONTarget+expandRuleTarget varMap (StaticTarget pMay) = StaticTarget $ fmap (expandReplacement varMap) pMay+expandRuleTarget varMap (TemplateTarget p) = TemplateTarget $ expandReplacement varMap p+expandRuleTarget varMap (RedirectTarget p) = RedirectTarget $ expandReplacement varMap p++expandReplacementBackend :: HashMap Text (GVal (Run (Writer Text) Text))+                         -> BackendSpec+                         -> BackendSpec+expandReplacementBackend varMap = omap (eitherThrow . expandReplacementText varMap)++data NonMatchReason =+    PathNotMatched | MethodNotMatched+    deriving (Eq, Ord, Enum, Show, Read)++-- | Alternative-like monoid append operator for Eithers over orderable Lefts.+-- The behavior is almost exactly like Alternative proper, except that when+-- both sides fail, the larger failure value prevails.+--+-- In other words:+--+-- Left 3 <|+> Left 2 == Left 3+-- Left 2 <|+> Left 3 == Left 3+-- Left 2 <|+> Right "Hello" == Right "Hello"+-- Right "Hello" <|+> Left 2 == Right "Hello"+-- Right "Hello" <|+> Right "Hello" == Right "Hello"+(<|+>) :: Ord e => Either e a -> Either e a -> Either e a+Left e1 <|+> Left e2 = Left (max e1 e2)+Left _ <|+> Right a = Right a+Right a <|+> _ = Right a++matchMethod :: Set HTTP.Method -> HTTP.Method -> Maybe HTTP.Method+matchMethod acceptedMethods method =+    if method `elem` acceptedMethods+        then Just method+        else Nothing++matchRule :: Rule -> HTTP.Method -> [Text] -> QueryText -> Either NonMatchReason (HashMap Text MatchedText)+matchRule rule method path query = do+    captures <- maybe (Left PathNotMatched) Right $+        matchPattern (ruleRoutePattern rule) path query+    maybe (Left MethodNotMatched) Right $+        matchMethod (ruleAcceptedMethods rule) method+    return captures++applyRule :: Rule+          -> HTTP.Method+          -> [Text]+          -> QueryText+          -> Either+                NonMatchReason+                ( Rule+                , HashMap Text MatchedText+                )+applyRule rule method path query = do+    captures <- matchRule rule method path query+    return (rule, captures)++applyRules :: [Rule]+           -> HTTP.Method+           -> [Text]+           -> QueryText+           -> Either+                 NonMatchReason+                 ( Rule+                 , HashMap Text MatchedText+                )+applyRules [] _ _ _ = Left PathNotMatched+applyRules (rule:rules) method path query =+    applyRule rule method path query <|+> applyRules rules method path query
+ src/Web/Sprinkles/Serve.hs view
@@ -0,0 +1,239 @@+{-#LANGUAGE NoImplicitPrelude #-}+{-#LANGUAGE OverloadedStrings #-}+{-#LANGUAGE OverloadedLists #-}+{-#LANGUAGE LambdaCase #-}+{-#LANGUAGE ScopedTypeVariables #-}+{-#LANGUAGE FlexibleInstances #-}+{-#LANGUAGE FlexibleContexts #-}+{-#LANGUAGE MultiParamTypeClasses #-}+module Web.Sprinkles.Serve+( serveProject+, appFromProject+)+where++import ClassyPrelude+import Control.Concurrent (forkIO)+import Data.Aeson as JSON+import Data.Aeson.Encode.Pretty as JSON+import Data.Aeson.TH as JSON+import qualified Data.ByteString.Lazy.UTF8 as LUTF8+import qualified Data.ByteString.UTF8 as UTF8+import Data.Default (def)+import qualified Data.Text as Text+import Data.Text (Text)+import Data.Time.Clock.POSIX (getPOSIXTime)+import Data.Yaml as YAML+import Data.AList (AList)+import Data.Time (formatTime, addUTCTime, getCurrentTime)++import Network.HTTP.Types+       (Status, status200, status302, status400, status404, status500)+import Network.HTTP.Types.URI (queryToQueryText)+import qualified Network.Wai as Wai+import Network.Wai (Response (..), mapResponseHeaders)+import qualified Network.Wai.Handler.CGI as CGI+import qualified Network.Wai.Handler.FastCGI as FastCGI+import qualified Network.Wai.Handler.SCGI as SCGI+import qualified Network.Wai.Handler.Warp as Warp+import Network.Wai.Middleware.Autohead (autohead)++import System.Environment (lookupEnv)+import System.Locale.Read (getLocale)+import qualified Text.Ginger as Ginger+import Text.Ginger+       (parseGinger, Template, runGingerT, GingerContext, GVal(..), ToGVal(..),+        (~>))+import Text.Ginger.Html (Html, htmlSource)+import qualified Text.Pandoc as Pandoc+import qualified Text.Pandoc.Readers.Creole as Pandoc++import Web.Sprinkles.Exceptions+import Web.Sprinkles.Backends+import Web.Sprinkles.Cache+import Web.Sprinkles.Logger as Logger+import Web.Sprinkles.Project+import Web.Sprinkles.ProjectConfig+import Web.Sprinkles.Rule+import Web.Sprinkles.ServerConfig+import Web.Sprinkles.Backends.Loader.Type+       (PostBodySource (..), pbsFromRequest, pbsInvalid)+import Web.Sprinkles.Handlers+       ( handleStaticTarget+       , handleNotFound+       , handleMethodNotAllowed+       , handleRedirectTarget+       , handleJSONTarget+       , handleTemplateTarget+       )+import Web.Sprinkles.Handlers.Respond+import Web.Sprinkles.Handlers.Common+       ( loadBackendDict+       , NotFoundException (..)+       , MethodNotAllowedException (..)+       , handle500+       , handle404+       )+import Web.Sprinkles.MatchedText (MatchedText (..))++serveProject :: ServerConfig -> Project -> IO ()+serveProject config project = do+    forkIO vacuum+    serve project+    where+        serve = case scDriver config of+            DefaultDriver -> serveWarp Nothing+            WarpDriver port -> serveWarp port+            CGIDriver -> serveCGI+            SCGIDriver -> serveSCGI+            FastCGIDriver -> serveFastCGI+        vacuum = forever $ do+            itemsCleared <- cacheVacuum (projectBackendCache project)+            when (itemsCleared > 0) $+                writeLog (projectLogger project) Notice $+                    "Cache items deleted: " <> tshow itemsCleared+            threadDelay 5000000 -- check every 5 seconds++serveWarp :: Maybe Int -> Project -> IO ()+serveWarp portMay project = do+    writeLog (projectLogger project) Notice $+        "Finding port for Warp: " <> tshow portMay+    port <- case portMay of+        Just p -> return p+        Nothing -> do+            portEnvStr <- lookupEnv "PORT"+            let portEnv = fromMaybe 5000 $ portEnvStr >>= readMay+            return portEnv+    writeLog (projectLogger project) Notice $+        "Running server on port " <> tshow port <> "..."+    Warp.run port (appFromProject project)++serveCGI :: Project -> IO ()+serveCGI project = CGI.run (appFromProject project)++serveSCGI :: Project -> IO ()+serveSCGI project = SCGI.run (appFromProject project)++serveFastCGI :: Project -> IO ()+serveFastCGI project = FastCGI.run (appFromProject project)++appFromProject :: Project -> Wai.Application+appFromProject project =+    middlewares go+    where+        middlewares :: Wai.Middleware+        middlewares = autohead++        go :: Wai.Application+        go request respond =+            handleRequest project request respond `catch` handleException respond++        handleException respond (e :: SomeException) = do+            writeLog (projectLogger project) Logger.Error . formatException $  e+            respond $+                Wai.responseLBS+                    status500+                    []+                    "Something went pear-shaped. It's bad, but the problem is still on our side."++handleRequest :: Project -> Wai.Application+handleRequest project request respond =+    go `catch` handleNotFound project request respond+       `catch` handleMethodNotAllowed project request respond+       `catch` \e -> handle500 e project request respond+    where+        go = do+            let path = Wai.pathInfo request+                query = queryToQueryText . Wai.queryString $ request+                method = Wai.requestMethod request+            let matchResult = applyRules+                    (pcRules . projectConfig $ project)+                    method+                    path+                    query+            case matchResult of+                Left PathNotMatched ->+                    throwM NotFoundException+                Left MethodNotMatched ->+                    throwM MethodNotAllowedException+                Right (rule, captures) ->+                    handleRule+                        rule+                        captures+                        project+                        request+                        respond++handleRule :: Rule -> HashMap Text MatchedText -> Project -> Wai.Application+handleRule rule captures project request respond = do+    let cache = projectBackendCache project+        capturesG = fmap toGVal captures+        globalBackendSpecs = pcContextData . projectConfig $ project+        backendSpecs = ruleContextData $ rule+        target = expandRuleTarget capturesG . ruleTarget $ rule+        logger = projectLogger project++    now <- getCurrentTime+    let oneYear = 86400 * 365 -- good enough+    let expiry = case ruleCaching rule of+            NoCache -> now+            CacheForever -> addUTCTime oneYear now+            MaxAge seconds -> addUTCTime (fromInteger seconds) now++    let respond' :: Wai.Response -> IO Wai.ResponseReceived+        respond' = respond . addExpiryHeader . overrideContentType++        overrideContentType :: Wai.Response -> Wai.Response+        overrideContentType =+            case ruleContentTypeOverride rule of+                Nothing -> id+                Just t ->+                    mapResponseHeaders (map $+                        \case+                            ("Content-type", _) -> ("Content-type", t)+                            x -> x+                    )++        addExpiryHeader :: Wai.Response -> Wai.Response+        addExpiryHeader =+            let expiryHeader =+                    ( "Expires"+                    , fromString $ formatTime+                        defaultTimeLocale+                        "%a, %d %b %Y %T GMT"+                        expiry+                    )+            in mapResponseHeaders (expiryHeader:)++    backendData :: HashMap Text (Items (BackendData IO Html))+                <- loadBackendDict+                        (writeLog logger)+                        (pbsFromRequest request)+                        cache+                        (globalBackendSpecs <> backendSpecs)+                        (ruleRequired rule)+                        capturesG++    let handle :: HashMap Text (Items (BackendData IO Html))+               -> Project+               -> Wai.Application+        handle = case target of+            RedirectTarget redirectPath ->+                handleRedirectTarget+                    redirectPath++            StaticTarget p ->+                handleStaticTarget p++            JSONTarget ->+                handleJSONTarget++            TemplateTarget templateName ->+                handleTemplateTarget+                    templateName++    handle+        backendData+        project+        request+        respond'
+ src/Web/Sprinkles/ServerConfig.hs view
@@ -0,0 +1,179 @@+{-#LANGUAGE NoImplicitPrelude #-}+{-#LANGUAGE OverloadedStrings #-}+{-#LANGUAGE OverloadedLists #-}+{-#LANGUAGE LambdaCase #-}+{-#LANGUAGE ScopedTypeVariables #-}+{-#LANGUAGE TypeSynonymInstances #-}+module Web.Sprinkles.ServerConfig+where++import ClassyPrelude+import Web.Sprinkles.Rule+import Data.Aeson as JSON+import Data.Aeson.TH+import qualified Data.Yaml as YAML+import Web.Sprinkles.Backends+import Data.Default+import System.FilePath.Glob (glob)+import System.Environment (getEnv, lookupEnv)+import Control.MaybeEitherMonad (maybeFail)+import System.Directory (doesFileExist)+import Data.Scientific (Scientific)+import Data.Time.Clock.POSIX (POSIXTime)+import Web.Sprinkles.Logger (LogLevel (..))+import Web.Sprinkles.Exceptions++data BackendCacheConfig =+    FilesystemCache FilePath POSIXTime |+    MemCache POSIXTime |+    MemcachedCache+    deriving (Show)++instance FromJSON BackendCacheConfig where+    parseJSON (String str) = maybeFail $ backendCacheConfigFromString str+    parseJSON (Object obj) = (obj .: "type") >>= \case+        "file" -> FilesystemCache <$>+                    (obj .:? "dir" .!= ".cache") <*>+                    (obj .:? "max-age" .!= 300)+        "mem" -> MemCache <$>+                    (obj .:? "max-age" .!= 60)+        "memcached" -> return MemcachedCache+        x -> fail $ "Invalid backend cache type: '" <> x+    parseJSON x = fail $ "Invalid backend cache specification: " <> show x++backendCacheConfigFromString :: Text -> Maybe BackendCacheConfig+backendCacheConfigFromString str =+    case splitSeq ":" str of+        ["file", dir] -> return $ FilesystemCache (unpack dir) 300+        ["file"] -> return $ FilesystemCache ".cache" 300+        ["mem"] -> return $ MemCache 60+        ["memcached"] -> return MemcachedCache+        xs -> Nothing++data ServerDriver = WarpDriver (Maybe Int)+                  | CGIDriver+                  | SCGIDriver+                  | FastCGIDriver+                  | DefaultDriver+    deriving (Show, Read, Eq)++instance Default ServerDriver where+    def = DefaultDriver++instance FromJSON ServerDriver where+    parseJSON (String "warp") =+        return $ WarpDriver Nothing+    parseJSON (String "cgi") =+        return CGIDriver+    parseJSON (String "fastcgi") =+        return FastCGIDriver+    parseJSON (String "fcgi") =+        return FastCGIDriver+    parseJSON (String "scgi") =+        return SCGIDriver+    parseJSON (String "default") =+        return def+    parseJSON (Object o) = do+        st :: Text <- o .: "type"+        case st of+            "warp" -> WarpDriver <$> o .:? "port"+            "cgi" -> return CGIDriver+            "fcgi" -> return FastCGIDriver+            "fastcgi" -> return FastCGIDriver+            "scgi" -> return SCGIDriver++data LoggerConfig =+    DiscardLog |+    Syslog LogLevel |+    StdioLog LogLevel+    deriving (Show)++instance FromJSON LoggerConfig where+    parseJSON (Object obj) = do+        dest <- obj .:? "destination"+        case dest :: Maybe Text of+            Nothing -> return DiscardLog+            Just "discard" -> return DiscardLog+            Just "null" -> return DiscardLog+            Just "stdio" ->+                StdioLog . fromMaybe Warning <$> obj .:? "level"+            Just "syslog" ->+                Syslog . fromMaybe Warning <$> obj .:? "level"++    parseJSON _ = fail "Invalid logger config"++data ServerConfig =+    ServerConfig+        { scBackendCache :: [BackendCacheConfig]+        , scDriver :: ServerDriver+        , scLogger :: Maybe LoggerConfig+        }+        deriving (Show)++instance Default ServerConfig where+    def = ServerConfig+            { scBackendCache = def+            , scDriver = def+            , scLogger = Nothing+            }++instance Monoid ServerConfig where+    mempty = def+    mappend = scAppend++instance FromJSON ServerConfig where+    parseJSON (Object obj) = do+        caches <- fromMaybe []+                    <$> ( obj .:? "backend-cache"+                          <|> (fmap (:[]) <$> obj .:? "backend-cache")+                        )+        driver <- fromMaybe def+                    <$> ( obj .:? "driver" )+        logger <- obj .:? "log"+        return ServerConfig+            { scBackendCache = caches+            , scDriver = driver+            , scLogger = logger+            }+    parseJSON _ = fail "Invalid server config"++scAppend :: ServerConfig -> ServerConfig -> ServerConfig+scAppend a b =+    ServerConfig+        { scBackendCache =+            firstNonNull (scBackendCache b) (scBackendCache a)+        , scLogger = scLogger b <|> scLogger a+        , scDriver =+            if scDriver b == DefaultDriver+                then scDriver a+                else scDriver b+        }++firstNonNull :: [a] -> [a] -> [a]+firstNonNull [] xs = xs+firstNonNull xs _ = xs++loadServerConfigFile :: FilePath -> IO ServerConfig+loadServerConfigFile fn =+    YAML.decodeFileEither fn >>=+        either+            (throwM . withSourceContext (pack fn))+            return++loadServerConfig :: FilePath -> IO ServerConfig+loadServerConfig dir = do+    homeDirMay <- lookupEnv "HOME"+    let systemGlobalFilename = "/etc/sprinkles/server.yml"+        globalFilename = "/usr/local/etc/sprinkles/server.yml"+        userFilenameMay = (</> ".config" </> "sprinkles" </> "server.yml") <$> homeDirMay+        localFilename = dir </> "config" </> "server.yml"+        serverConfigFilename = dir </> "server.yml"+    let filenames' = catMaybes+            [ Just systemGlobalFilename+            , Just globalFilename+            , userFilenameMay+            , Just localFilename+            , Just serverConfigFilename+            ]+    filenames <- filterM doesFileExist filenames'+    mconcat <$> forM filenames loadServerConfigFile
+ test/Spec.hs view
@@ -0,0 +1,13 @@+import Test.Tasty++import Web.Sprinkles.PatternTest (patternTests)+import Web.Sprinkles.ApplicationTest (applicationTests)++main :: IO ()+main = defaultMain allTests++allTests =+    testGroup "All Tests"+        [ patternTests+        , applicationTests+        ]
+ test/Web/Sprinkles/ApplicationTest.hs view
@@ -0,0 +1,72 @@+{-#LANGUAGE OverloadedStrings #-}+{-#LANGUAGE QuasiQuotes #-}+{-#LANGUAGE NoImplicitPrelude #-}+module Web.Sprinkles.ApplicationTest+where++import ClassyPrelude+import Web.Sprinkles.Project (Project (..), loadProject)+import Web.Sprinkles.Serve (appFromProject)+import Web.Sprinkles.Logger (Logger (..), LogMessage (..), tChanLogger)+import System.Directory+import System.FilePath+import System.IO.Temp+import Data.Default (def)+import Test.Tasty+import Test.Tasty.HUnit+import Network.Wai.Test+import Text.Heredoc++applicationTests :: TestTree+applicationTests = testGroup "Application"+    [ testCase "Serve blank page" testServeBlankPage+    ]++testServeBlankPage = do+    let projectFiles =+            [ ( "project.yml"+              , [str|rules:+                    |  - pattern: '/'+                    |    template: 'index.html'+                    |])+            , ( "templates/index.html"+              , "All is well."+              )+            ]+    withFakeProject projectFiles . runProjectSession $ do+        response <- request (setPath defaultRequest "/")+        assertStatus 200 response+        assertContentType "text/html" response+        assertBody "All is well." response++runProjectSession :: Session a -> Project -> IO a+runProjectSession action project =+    runSession action (appFromProject project)++withFakeProject :: [(FilePath, ByteString)] -> (Project -> IO ()) -> IO ()+withFakeProject files inner = do+    withSystemTempDirectory "sprinkles-fake-project-" $ \projectRoot ->+        bracket (acquire projectRoot) release go+    where+        acquire :: FilePath -> IO FilePath+        acquire projectRoot = do+            setCurrentDirectory projectRoot+            forM files $ \(filename, contents) -> do+                let dirname = takeDirectory filename+                createDirectoryIfMissing True dirname+                writeFile filename contents+            return projectRoot++        release :: FilePath -> IO ()+        release projectRoot = return ()++        go :: FilePath -> IO ()+        go dir = do+            let sconfig = def+            logChan <- newTChanIO+            project <- setFakeLogger logChan <$> loadProject sconfig "."+            inner project++        setFakeLogger :: TChan LogMessage -> Project -> Project+        setFakeLogger logChan project =+            project { projectLogger = tChanLogger logChan }
+ test/Web/Sprinkles/PatternTest.hs view
@@ -0,0 +1,237 @@+{-#LANGUAGE NoImplicitPrelude #-}+{-#LANGUAGE OverloadedStrings #-}+module Web.Sprinkles.PatternTest+where++import ClassyPrelude+import Web.Sprinkles.Pattern+import Test.Tasty+import Test.Tasty.HUnit+import qualified Text.Regex.PCRE as RE++patternTests =+    testGroup "Web.Sprinkles.Pattern"+        [ matchPatternTests+        , parsePatternTests+        ]++-- * Testing matchPattern++matchPatternTests = testGroup "matchPattern"+    [ matchPatternSingleExactlyTest+    , matchPatternSingleAnyTest+    , matchPatternSingleRegexTest+    , matchPatternCombinedExactlyAnyTest+    , matchFailExcessiveTest+    , matchRealWorldExampleTest1+    ]++matchPatternSingleExactlyTest =+    testCase "single Exactly" $ do+        let pattern = Pattern+                [PatternPathItem Nothing (Exactly "hello") MatchOne]+                []+            path = ["hello"]+            query = []+            actual = matchPattern pattern path query+            expected = Just $ mapFromList []+        assertEqual "" expected actual++matchPatternSingleAnyTest =+    testCase "single Any" $ do+        let pattern = Pattern [PatternPathItem (Just "who") Any MatchOne] []+            path = ["hello"]+            query = []+            actual = matchPattern pattern path query+            expected = Just $ mapFromList [("who", "hello")]+        assertEqual "" expected actual++matchPatternSingleRegexTest =+    testCase "single Regex" $ do+        let pattern = Pattern+                        [ PatternPathItem+                            (Just "who")+                            (Regex "hello, [a-z]*" RE.compBlank)+                            MatchOne+                        ]+                        []+            path = ["hello, world"]+            query = []+            actual = matchPattern pattern path query+            expected = Just $ mapFromList [("who", "hello, world")]+        assertEqual "" expected actual++matchPatternCombinedExactlyAnyTest =+    testCase "combined Exactly Any" $ do+        let pattern = Pattern+                            [ PatternPathItem Nothing (Exactly "hello") MatchOne+                            , PatternPathItem (Just "who") Any MatchOne+                            , PatternPathItem Nothing (Exactly "world") MatchOne+                            ]+                            []+            path = ["hello", "who", "world"]+            query = []+            actual = matchPattern pattern path query+            expected = Just $ mapFromList [("who", "who")]+        assertEqual "" expected actual++matchFailExcessiveTest =+    testCase "fail excessive" $ do+        let pattern = Pattern+                            [ PatternPathItem Nothing (Exactly "hello") MatchOne+                            , PatternPathItem (Just "who") Any MatchOne+                            ]+                            []+            path = ["hello", "world", "me"]+            query = []+            actual = matchPattern pattern path query+            expected = Nothing+        assertEqual "" expected actual++matchRealWorldExampleTest1 =+    testCase "real world example 1" $ do+        let pattern = Pattern+                            [ PatternPathItem Nothing (Exactly "country") MatchOne+                            ]+                            [ PatternQueryItem (Just "lang") "lang" Any True+                            ]+            path = ["country"]+            query =+                [ ("lang", Just "de")+                , ("country", Just "DE")+                , ("username", Just "demo")+                , ("style", Just "full")+                ]+            actual = matchPattern pattern path query+            expected = Just $ mapFromList [("lang", "de")]+        assertEqual "" expected actual++-- * Testing parsePattern++parsePatternTests =+    testGroup "parsePattern"+        [ parseSimpleExactlyTest+        , parseNamedExactlyTest+        , parseSimpleAnyTest+        , parseNamedAnyTest+        , parseNamedRegexTest+        , parseShorthandAnyTest+        , parseSimpleAnyMultiTest+        , parseNamedAnyMultiTest+        , parseShorthandAnyMultiTest+        , parseNamedWithUnderscore+        , parseRealWorldExampleTest1+        ]++parseSimpleExactlyTest =+    testCase "parse simple Exactly" $ do+        let src = "/hello"+            expected = Right $ Pattern+                        [ PatternPathItem Nothing (Exactly "hello") MatchOne+                        ]+                        []+            actual = parsePattern src+        assertEqual "" expected actual++parseNamedExactlyTest =+    testCase "parse named Exactly" $ do+        let src = "/{{who:hello}}"+            expected = Right $ Pattern+                        [ PatternPathItem (Just "who") (Exactly "hello") MatchOne+                        ]+                        []+            actual = parsePattern src+        assertEqual "" expected actual++parseSimpleAnyTest =+    testCase "parse simple Any" $ do+        let src = "/{{*}}"+            expected = Right $ Pattern+                        [ PatternPathItem Nothing Any MatchOne+                        ]+                        []+            actual = parsePattern src+        assertEqual "" expected actual++parseShorthandAnyTest =+    testCase "parse shorthand Any" $ do+        let src = "/*"+            expected = Right $ Pattern+                        [ PatternPathItem Nothing Any MatchOne+                        ]+                        []+            actual = parsePattern src+        assertEqual "" expected actual++parseNamedAnyTest =+    testCase "parse named Any" $ do+        let src = "/{{who:*}}"+            expected = Right $ Pattern+                        [ PatternPathItem (Just "who") Any MatchOne+                        ]+                        []+            actual = parsePattern src+        assertEqual "" expected actual++parseNamedRegexTest =+    testCase "parse named Regex" $ do+        let src = "/{{who:/foo/}}"+            expected = Right $ Pattern+                        [ PatternPathItem (Just "who") (Regex "foo" RE.compBlank) MatchOne+                        ]+                        []+            actual = parsePattern src+        assertEqual "" expected actual++parseSimpleAnyMultiTest =+    testCase "parse simple Any" $ do+        let src = "/{{**}}"+            expected = Right $ Pattern+                        [ PatternPathItem Nothing Any MatchMany+                        ]+                        []+            actual = parsePattern src+        assertEqual "" expected actual++parseShorthandAnyMultiTest =+    testCase "parse shorthand Any" $ do+        let src = "/**"+            expected = Right $ Pattern+                        [ PatternPathItem Nothing Any MatchMany+                        ]+                        []+            actual = parsePattern src+        assertEqual "" expected actual++parseNamedAnyMultiTest =+    testCase "parse named Any" $ do+        let src = "/{{who:**}}"+            expected = Right $ Pattern+                        [ PatternPathItem (Just "who") Any MatchMany+                        ]+                        []+            actual = parsePattern src+        assertEqual "" expected actual++parseNamedWithUnderscore =+    testCase "parse named Any" $ do+        let src = "/{{who_is:*}}"+            expected = Right $ Pattern+                        [ PatternPathItem (Just "who_is") Any MatchOne+                        ]+                        []+            actual = parsePattern src+        assertEqual "" expected actual+++parseRealWorldExampleTest1 =+    testCase "parse real world example 1" $ do+        let src = "/country?query={{query:*}}"+            expected = Right $ Pattern+                        [ PatternPathItem Nothing (Exactly "country") MatchOne+                        ]+                        [ PatternQueryItem (Just "query") "query" Any True+                        ]+            actual = parsePattern src+        assertEqual "" expected actual+