diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -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 diff --git a/sprinkles.cabal b/sprinkles.cabal new file mode 100644 --- /dev/null +++ b/sprinkles.cabal @@ -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 diff --git a/src/Control/MaybeEitherMonad.hs b/src/Control/MaybeEitherMonad.hs new file mode 100644 --- /dev/null +++ b/src/Control/MaybeEitherMonad.hs @@ -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 ()) diff --git a/src/Data/AList.hs b/src/Data/AList.hs new file mode 100644 --- /dev/null +++ b/src/Data/AList.hs @@ -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)] diff --git a/src/Data/EmbedVersion.hs b/src/Data/EmbedVersion.hs new file mode 100644 --- /dev/null +++ b/src/Data/EmbedVersion.hs @@ -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 diff --git a/src/Data/Walk.hs b/src/Data/Walk.hs new file mode 100644 --- /dev/null +++ b/src/Data/Walk.hs @@ -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 diff --git a/src/Web/Sprinkles.hs b/src/Web/Sprinkles.hs new file mode 100644 --- /dev/null +++ b/src/Web/Sprinkles.hs @@ -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 + diff --git a/src/Web/Sprinkles/Backends.hs b/src/Web/Sprinkles/Backends.hs new file mode 100644 --- /dev/null +++ b/src/Web/Sprinkles/Backends.hs @@ -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 } } diff --git a/src/Web/Sprinkles/Backends/Data.hs b/src/Web/Sprinkles/Backends/Data.hs new file mode 100644 --- /dev/null +++ b/src/Web/Sprinkles/Backends/Data.hs @@ -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 + ] + + diff --git a/src/Web/Sprinkles/Backends/Loader.hs b/src/Web/Sprinkles/Backends/Loader.hs new file mode 100644 --- /dev/null +++ b/src/Web/Sprinkles/Backends/Loader.hs @@ -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 diff --git a/src/Web/Sprinkles/Backends/Loader/FileLoader.hs b/src/Web/Sprinkles/Backends/Loader/FileLoader.hs new file mode 100644 --- /dev/null +++ b/src/Web/Sprinkles/Backends/Loader/FileLoader.hs @@ -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 + diff --git a/src/Web/Sprinkles/Backends/Loader/HttpLoader.hs b/src/Web/Sprinkles/Backends/Loader/HttpLoader.hs new file mode 100644 --- /dev/null +++ b/src/Web/Sprinkles/Backends/Loader/HttpLoader.hs @@ -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] diff --git a/src/Web/Sprinkles/Backends/Loader/LiteralLoader.hs b/src/Web/Sprinkles/Backends/Loader/LiteralLoader.hs new file mode 100644 --- /dev/null +++ b/src/Web/Sprinkles/Backends/Loader/LiteralLoader.hs @@ -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 ] diff --git a/src/Web/Sprinkles/Backends/Loader/RequestBodyLoader.hs b/src/Web/Sprinkles/Backends/Loader/RequestBodyLoader.hs new file mode 100644 --- /dev/null +++ b/src/Web/Sprinkles/Backends/Loader/RequestBodyLoader.hs @@ -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] diff --git a/src/Web/Sprinkles/Backends/Loader/SqlLoader.hs b/src/Web/Sprinkles/Backends/Loader/SqlLoader.hs new file mode 100644 --- /dev/null +++ b/src/Web/Sprinkles/Backends/Loader/SqlLoader.hs @@ -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) diff --git a/src/Web/Sprinkles/Backends/Loader/SubprocessLoader.hs b/src/Web/Sprinkles/Backends/Loader/SubprocessLoader.hs new file mode 100644 --- /dev/null +++ b/src/Web/Sprinkles/Backends/Loader/SubprocessLoader.hs @@ -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)] diff --git a/src/Web/Sprinkles/Backends/Loader/Type.hs b/src/Web/Sprinkles/Backends/Loader/Type.hs new file mode 100644 --- /dev/null +++ b/src/Web/Sprinkles/Backends/Loader/Type.hs @@ -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" + } + diff --git a/src/Web/Sprinkles/Backends/Parsers.hs b/src/Web/Sprinkles/Backends/Parsers.hs new file mode 100644 --- /dev/null +++ b/src/Web/Sprinkles/Backends/Parsers.hs @@ -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) + diff --git a/src/Web/Sprinkles/Backends/Spec.hs b/src/Web/Sprinkles/Backends/Spec.hs new file mode 100644 --- /dev/null +++ b/src/Web/Sprinkles/Backends/Spec.hs @@ -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 diff --git a/src/Web/Sprinkles/Cache.hs b/src/Web/Sprinkles/Cache.hs new file mode 100644 --- /dev/null +++ b/src/Web/Sprinkles/Cache.hs @@ -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 + } diff --git a/src/Web/Sprinkles/Cache/Filesystem.hs b/src/Web/Sprinkles/Cache/Filesystem.hs new file mode 100644 --- /dev/null +++ b/src/Web/Sprinkles/Cache/Filesystem.hs @@ -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 diff --git a/src/Web/Sprinkles/Cache/Memcached.hs b/src/Web/Sprinkles/Cache/Memcached.hs new file mode 100644 --- /dev/null +++ b/src/Web/Sprinkles/Cache/Memcached.hs @@ -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 + } diff --git a/src/Web/Sprinkles/Cache/Memory.hs b/src/Web/Sprinkles/Cache/Memory.hs new file mode 100644 --- /dev/null +++ b/src/Web/Sprinkles/Cache/Memory.hs @@ -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) + } diff --git a/src/Web/Sprinkles/Databases.hs b/src/Web/Sprinkles/Databases.hs new file mode 100644 --- /dev/null +++ b/src/Web/Sprinkles/Databases.hs @@ -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 diff --git a/src/Web/Sprinkles/Exceptions.hs b/src/Web/Sprinkles/Exceptions.hs new file mode 100644 --- /dev/null +++ b/src/Web/Sprinkles/Exceptions.hs @@ -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 diff --git a/src/Web/Sprinkles/Handlers.hs b/src/Web/Sprinkles/Handlers.hs new file mode 100644 --- /dev/null +++ b/src/Web/Sprinkles/Handlers.hs @@ -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 diff --git a/src/Web/Sprinkles/Handlers/Common.hs b/src/Web/Sprinkles/Handlers/Common.hs new file mode 100644 --- /dev/null +++ b/src/Web/Sprinkles/Handlers/Common.hs @@ -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 diff --git a/src/Web/Sprinkles/Handlers/JSON.hs b/src/Web/Sprinkles/Handlers/JSON.hs new file mode 100644 --- /dev/null +++ b/src/Web/Sprinkles/Handlers/JSON.hs @@ -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) + + diff --git a/src/Web/Sprinkles/Handlers/Redirect.hs b/src/Web/Sprinkles/Handlers/Redirect.hs new file mode 100644 --- /dev/null +++ b/src/Web/Sprinkles/Handlers/Redirect.hs @@ -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)] + "" + diff --git a/src/Web/Sprinkles/Handlers/Respond.hs b/src/Web/Sprinkles/Handlers/Respond.hs new file mode 100644 --- /dev/null +++ b/src/Web/Sprinkles/Handlers/Respond.hs @@ -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 diff --git a/src/Web/Sprinkles/Handlers/Static.hs b/src/Web/Sprinkles/Handlers/Static.hs new file mode 100644 --- /dev/null +++ b/src/Web/Sprinkles/Handlers/Static.hs @@ -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 diff --git a/src/Web/Sprinkles/Handlers/Template.hs b/src/Web/Sprinkles/Handlers/Template.hs new file mode 100644 --- /dev/null +++ b/src/Web/Sprinkles/Handlers/Template.hs @@ -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 diff --git a/src/Web/Sprinkles/Logger.hs b/src/Web/Sprinkles/Logger.hs new file mode 100644 --- /dev/null +++ b/src/Web/Sprinkles/Logger.hs @@ -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) diff --git a/src/Web/Sprinkles/MatchedText.hs b/src/Web/Sprinkles/MatchedText.hs new file mode 100644 --- /dev/null +++ b/src/Web/Sprinkles/MatchedText.hs @@ -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 diff --git a/src/Web/Sprinkles/PandocGVal.hs b/src/Web/Sprinkles/PandocGVal.hs new file mode 100644 --- /dev/null +++ b/src/Web/Sprinkles/PandocGVal.hs @@ -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 diff --git a/src/Web/Sprinkles/Pattern.hs b/src/Web/Sprinkles/Pattern.hs new file mode 100644 --- /dev/null +++ b/src/Web/Sprinkles/Pattern.hs @@ -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 diff --git a/src/Web/Sprinkles/Project.hs b/src/Web/Sprinkles/Project.hs new file mode 100644 --- /dev/null +++ b/src/Web/Sprinkles/Project.hs @@ -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) + + diff --git a/src/Web/Sprinkles/ProjectConfig.hs b/src/Web/Sprinkles/ProjectConfig.hs new file mode 100644 --- /dev/null +++ b/src/Web/Sprinkles/ProjectConfig.hs @@ -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" + diff --git a/src/Web/Sprinkles/Replacement.hs b/src/Web/Sprinkles/Replacement.hs new file mode 100644 --- /dev/null +++ b/src/Web/Sprinkles/Replacement.hs @@ -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 diff --git a/src/Web/Sprinkles/Rule.hs b/src/Web/Sprinkles/Rule.hs new file mode 100644 --- /dev/null +++ b/src/Web/Sprinkles/Rule.hs @@ -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 diff --git a/src/Web/Sprinkles/Serve.hs b/src/Web/Sprinkles/Serve.hs new file mode 100644 --- /dev/null +++ b/src/Web/Sprinkles/Serve.hs @@ -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' diff --git a/src/Web/Sprinkles/ServerConfig.hs b/src/Web/Sprinkles/ServerConfig.hs new file mode 100644 --- /dev/null +++ b/src/Web/Sprinkles/ServerConfig.hs @@ -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 diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -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 + ] diff --git a/test/Web/Sprinkles/ApplicationTest.hs b/test/Web/Sprinkles/ApplicationTest.hs new file mode 100644 --- /dev/null +++ b/test/Web/Sprinkles/ApplicationTest.hs @@ -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 } diff --git a/test/Web/Sprinkles/PatternTest.hs b/test/Web/Sprinkles/PatternTest.hs new file mode 100644 --- /dev/null +++ b/test/Web/Sprinkles/PatternTest.hs @@ -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 +