diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -2,23 +2,29 @@ {-#LANGUAGE OverloadedStrings #-} {-#LANGUAGE TemplateHaskell #-} {-#LANGUAGE ScopedTypeVariables #-} +{-#LANGUAGE LambdaCase #-} -- | CLI program that drives a Sprinkles instance. module Main where -import ClassyPrelude hiding ( (<|>), try ) +import Web.Sprinkles.Prelude hiding ( (<|>), try ) import Web.Sprinkles +import Web.Sprinkles.Project (Project) import Web.Sprinkles.Exceptions import Text.Read (read, readMaybe) import Data.Default (def) import Text.Parsec import Data.EmbedVersion +import qualified Data.Text as Text +import Control.Concurrent.Async data CliOptions = ServeProject ServerConfig | + BakeProject FilePath ServerConfig [FilePath] | DumpVersion + deriving (Show) -parseArgs :: [Text] -> IO CliOptions +parseArgs :: [Text] -> IO [CliOptions] parseArgs argv = do let result = runParser argsP () "command line arguments" argv either @@ -33,8 +39,8 @@ | Required Text (Text -> Maybe a) | Bare (Text -> Maybe a) -argsP :: ArgsP CliOptions -argsP = versionP <|> serveArgsP +argsP :: ArgsP [CliOptions] +argsP = some (versionP <|> bakeArgsP <|> serveArgsP) <* eof versionP :: ArgsP CliOptions versionP = @@ -44,9 +50,18 @@ serveArgsP :: ArgsP CliOptions serveArgsP = do - pipeline <- Text.Parsec.many $ choice (map (Text.Parsec.try . argP) argSpecs) + try $ tExactly "-serve" + pipeline <- Text.Parsec.many $ choice (map (Text.Parsec.try . serveArgP) serveArgSpecs) return . ServeProject $ foldr ($) def pipeline +bakeArgsP :: ArgsP CliOptions +bakeArgsP = do + try $ tExactly "-bake" + -- dirname <- try $ serveArgP (Optional "o" $ Just . Text.unpack . fromMaybe "./baked") + let dirname = "./baked" + extraEntryPoints <- fmap Text.unpack <$> Text.Parsec.many bareArgP + return $ BakeProject dirname def extraEntryPoints + tSatisfy :: (Show t, Stream s m t) => (t -> Bool) -> ParsecT s u m t tSatisfy cond = do actual <- anyToken @@ -63,29 +78,32 @@ isNotFlag :: Text -> Bool isNotFlag = not . isFlag -argP :: ArgSpec a -> ArgsP a -argP (Flag str x) = do +serveArgP :: ArgSpec a -> ArgsP a +serveArgP (Flag str x) = do tExactly ("-" <> str) return x -argP (Optional str f) = do +serveArgP (Optional str f) = do tExactly ("-" <> str) - paramMay <- optionMaybe (tSatisfy isNotFlag) + paramMay <- optionMaybe bareArgP maybe (fail "invalid parameter") return (f paramMay) -argP (Required str f) = do +serveArgP (Required str f) = do tExactly ("-" <> str) - param <- tSatisfy isNotFlag + param <- bareArgP maybe (fail "invalid parameter") return (f param) -argP (Bare f) = - (f <$> tSatisfy isNotFlag) >>= maybe (fail "invalid bare argument") return +serveArgP (Bare f) = + (f <$> bareArgP) >>= maybe (fail "invalid bare argument") return -argSpecs :: [ArgSpec (ServerConfig -> ServerConfig)] -argSpecs = +bareArgP :: ArgsP Text +bareArgP = tSatisfy isNotFlag + +serveArgSpecs :: [ArgSpec (ServerConfig -> ServerConfig)] +serveArgSpecs = [ Optional "warp" (maybe @@ -94,6 +112,9 @@ port <- readMaybe . unpack $ str return $ \config -> config { scDriver = WarpDriver (Just port) }) ) + , Required + "dir" + (\str -> Just (\config -> config { scRootDir = unpack str })) , Bare (\str -> do port <- readMaybe . unpack $ str return $ \config -> config { scDriver = WarpDriver (Just port) }) @@ -102,21 +123,32 @@ , Flag "fcgi" (\config -> config { scDriver = FastCGIDriver }) ] +sprinklesVersion :: Text sprinklesVersion = $(embedPackageVersionStr "sprinkles.cabal") main :: IO () main = runMain `catch` handleUncaughtExceptions +prepareProject :: ServerConfig -> IO (ServerConfig, Project) +prepareProject sconfigA = do + sconfigF <- loadServerConfig $ scRootDir sconfigA + let sconfig = sconfigF `mappend` sconfigA + + project <- loadProject sconfig + return (sconfig, project) + runMain :: IO () runMain = do args <- getArgs opts <- parseArgs args - case opts of + forConcurrently_ opts $ \opt -> do + print opt + case opt of ServeProject sconfigA -> do - sconfigF <- loadServerConfig "." - let sconfig = sconfigF `mappend` sconfigA - - project <- loadProject sconfig "." - serveProject sconfig project + prepareProject sconfigA >>= \(sconfig, project) -> + serveProject sconfig project + BakeProject path sconfigA extraEntryPoints -> do + prepareProject sconfigA >>= \(sconfig, project) -> + bakeProject path project extraEntryPoints DumpVersion -> do putStrLn sprinklesVersion diff --git a/embedded/.htaccess b/embedded/.htaccess new file mode 100644 --- /dev/null +++ b/embedded/.htaccess @@ -0,0 +1,2 @@ +ErrorDocument 404 /_errors/404.html +AddCharset UTF-8 .html diff --git a/sprinkles.cabal b/sprinkles.cabal --- a/sprinkles.cabal +++ b/sprinkles.cabal @@ -1,8 +1,8 @@ name: sprinkles -version: 0.3.5.0 +version: 0.6.0.0 synopsis: JSON API to HTML website wrapper -description: Please see README.md -homepage: https://bitbucket.org/tdammers/sprinkles +description: Please see README.md. More text to please stack. More text to please stack. More text to please stack. More text to please stack. More text to please stack. More text to please stack. More text to please stack. More text to please stack. More text to please stack. More text to please stack. +homepage: https://sprinkles.tobiasdammers.nl/ license: BSD3 license-file: LICENSE author: Author name here @@ -10,12 +10,13 @@ copyright: 2016 Tobias Dammers category: Web build-type: Simple --- extra-source-files: +extra-source-files: embedded/.htaccess cabal-version: >=1.10 library hs-source-dirs: src exposed-modules: Web.Sprinkles + , Web.Sprinkles.Prelude , Web.Sprinkles.Logger , Web.Sprinkles.Exceptions , Web.Sprinkles.Databases @@ -23,8 +24,15 @@ , Web.Sprinkles.Cache.Filesystem , Web.Sprinkles.Cache.Memory , Web.Sprinkles.Cache.Memcached + , Web.Sprinkles.Pandoc + , Web.Sprinkles.Sessions + , Web.Sprinkles.SessionHandle + , Web.Sprinkles.SessionStore + , Web.Sprinkles.SessionStore.Database + , Web.Sprinkles.SessionStore.InProc , Web.Sprinkles.Pattern , Web.Sprinkles.Replacement + , Web.Sprinkles.TemplateContext , Web.Sprinkles.Backends , Web.Sprinkles.Backends.Loader , Web.Sprinkles.Backends.Spec @@ -51,63 +59,82 @@ , Web.Sprinkles.ServerConfig , Web.Sprinkles.Project , Web.Sprinkles.Serve + , Web.Sprinkles.Bake , Control.MaybeEitherMonad , Data.EmbedVersion , Data.AList - , Data.Walk + , Data.Expandable + , Data.RandomString + , Text.Pandoc.Readers.CustomCreole 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 + , Cabal >= 2.4.0 && <2.5 + , Glob >=0.9.3 && <0.10 + , HDBC >=2.4.0.2 && <2.5 + , HDBC-postgresql >=2.3.2.5 && <2.4 + , HDBC-sqlite3 >=2.3.3.1 && <2.4 + , HDBC-mysql >=0.7.1.0 && <0.8 + , HTTP >=4000.3.12 && <4000.4 + , SHA >=1.6.4.4 && <1.7 + , aeson >=1.3.1.1 && <1.4 + , aeson-pretty >=0.8.7 && <0.9 + , array >=0.5.0 && <0.6 + , base64-bytestring >=1.0.0.1 && <1.1 + , bcrypt >=0.0.11 && <0.1 + , bytestring >=0.10.8.2 && <0.11 + , case-insensitive >=1.2.0.11 && <1.3 + , cereal >=0.5.7.0 && <0.6 + , containers >=0.5.11.0 && <0.6 + , css-syntax >=0.0.8 && <0.1 + , curl >=1.3.8 && <1.4 + , data-default >=0.7.1.1 && <0.8 + , directory >=1.3.1.5 && <1.4 + , extra >=1.6.12 && <1.7 + , file-embed >=0.0.10.1 && <0.1 + , filepath >=1.4.2 && <1.5 + , ginger >=0.8.1.0 && <0.9 + , hashable >=1.2.7.0 && <1.3 + , heredoc >=0.2.0.0 && <0.3 + , hsyslog >=5.0.1 && <5.1 + , http-types >=0.12.2 && <0.13 + , lens >=4.17 && <4.18 + , memcache >=0.2.0.1 && <0.3 + , mime-types >=0.1.0.8 && <0.2 + , mtl >=2.2.2 && <2.3 + , network-uri >=2.6.1.0 && <2.7 + , nonce >=1.0.7 && <1.1 + , pandoc >=2.2.1 && <2.3 + , pandoc-types >=1.17.5.1 && <1.18 + , parsec >=3.1.13.0 && <3.2 + , process >=1.6.3.0 && <1.7 + , random >=1.1 && <1.2 + , random-shuffle >=0.0.4 && <0.1 + , regex-base >=0.93.2 && <0.94 + , regex-pcre >=0.94.4 && <0.95 + , safe >=0.3.17 && <0.4 + , scientific >=0.3.6.2 && <0.4 + , split >=0.2.3.3 && <0.3 + , stm >=2.4.5.1 && <2.5 + , system-locale >=0.2.0.0 && <0.3 + , tagsoup >=0.14.7 && <0.15 + , template-haskell >=2.2.0.0 && <2.14 + , text >=1.2.3.1 && <1.3 + , time >=1.8.0.2 && <1.9 + , transformers >=0.5.5.0 && <0.6 + , unix-compat >=0.5.1 && <0.6 + , unix-time >=0.3.8 && <0.4 + , unordered-containers >=0.2.9.0 && <0.3 + , unordered-containers >=0.2.9.0 && <0.3 + , utf8-string >=1.0.1.1 && <1.1 + , vector >=0.12.0.1 && <0.13 + , wai >=3.2.1.2 && <3.3 + , wai-extra >=3.0.24.3 && <3.1 + , wai-extra >=3.0.24.3 && <3.1 + , wai-handler-fastcgi >=3.0.0.2 && <3.1 + , warp >=3.2.25 && <3.3 + , yaml >=0.8.32 && <0.12 + , yeshql-hdbc >=4.1.0.1 && <4.2 default-language: Haskell2010 + ghc-options: -fwarn-incomplete-patterns executable sprinkles hs-source-dirs: app @@ -115,9 +142,10 @@ ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: base , sprinkles - , classy-prelude + , async , data-default , safe + , text , parsec default-language: Haskell2010 @@ -129,7 +157,6 @@ , Web.Sprinkles.ApplicationTest build-depends: base , sprinkles - , classy-prelude , data-default , directory , filepath diff --git a/src/Data/AList.hs b/src/Data/AList.hs --- a/src/Data/AList.hs +++ b/src/Data/AList.hs @@ -12,7 +12,7 @@ ) where -import ClassyPrelude hiding (fromList, toList, singleton, empty) +import Web.Sprinkles.Prelude hiding (fromList, toList, singleton, empty) import Data.Aeson (ToJSON (..), FromJSON (..), Value (..)) import qualified Data.HashMap.Strict as HashMap import Data.Monoid diff --git a/src/Data/EmbedVersion.hs b/src/Data/EmbedVersion.hs --- a/src/Data/EmbedVersion.hs +++ b/src/Data/EmbedVersion.hs @@ -7,7 +7,7 @@ import Distribution.Verbosity import Distribution.Package import Distribution.PackageDescription -import Distribution.PackageDescription.Parse +import Distribution.PackageDescription.Parsec import Language.Haskell.TH import Language.Haskell.TH.Syntax import Data.List (intercalate, isPrefixOf) @@ -21,7 +21,7 @@ getPackageVersion :: FilePath -> IO Version getPackageVersion cabalFileName = do - gpd <- readPackageDescription silent cabalFileName + gpd <- readGenericPackageDescription silent cabalFileName return . pkgVersion . package. packageDescription $ gpd getPackageVersionStr :: FilePath -> IO String @@ -60,7 +60,7 @@ formatPackageVersion :: Version -> String formatPackageVersion = - intercalate "." . map show . versionBranch + intercalate "." . map show . versionNumbers embedPackageVersionStr :: FilePath -> Q Exp embedPackageVersionStr fp = do diff --git a/src/Data/Expandable.hs b/src/Data/Expandable.hs new file mode 100644 --- /dev/null +++ b/src/Data/Expandable.hs @@ -0,0 +1,48 @@ +{-#LANGUAGE MultiParamTypeClasses #-} +{-#LANGUAGE FlexibleInstances #-} +{-#LANGUAGE RankNTypes #-} + +module Data.Expandable +( ExpandableM (..) +, expand +) +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 +import Control.Monad.Identity + +class ExpandableM t a where + expandM :: forall m. Monad m => (t -> m t) -> a -> m a + +expand :: ExpandableM t a => (t -> t) -> a -> a +expand f x = runIdentity $ expandM (return . f) x + +instance ExpandableM t t where + expandM f x = f x + +instance ExpandableM t a => ExpandableM t (Maybe a) where + expandM _ Nothing = return Nothing + expandM f (Just x) = Just <$> expandM f x + +instance ExpandableM t a => ExpandableM t [a] where + expandM f xs = mapM (expandM f) xs + +instance ExpandableM Text JSON.Value where + expandM = jsonTextWalk + +instance (ExpandableM t a, ExpandableM t b) => ExpandableM t (a, b) where + expandM f (x, y) = (,) <$> expandM f x <*> expandM f y + +jsonTextWalk :: Monad m => (Text -> m Text) -> (JSON.Value -> m JSON.Value) +jsonTextWalk f (JSON.String t) = JSON.String <$> f t +jsonTextWalk f (JSON.Array v) = JSON.Array <$> sequence (fmap (expandM f) v) +jsonTextWalk f (JSON.Object o) = + JSON.Object . HashMap.fromList <$> (expandM f . HashMap.toList) o +jsonTextWalk _ x = return x + diff --git a/src/Data/RandomString.hs b/src/Data/RandomString.hs new file mode 100644 --- /dev/null +++ b/src/Data/RandomString.hs @@ -0,0 +1,21 @@ +{-#LANGUAGE NoImplicitPrelude #-} +{-#LANGUAGE ScopedTypeVariables #-} + +module Data.RandomString +( randomStr +) +where + +import Web.Sprinkles.Prelude +import System.Random + +randomStr :: [Char] -> Int -> IO String +randomStr alphabet desiredLength = do + let alphabetSize :: Int + alphabetSize = Web.Sprinkles.Prelude.length alphabet + when (alphabetSize < 1) $ + error "randomStr: empty list of allowed characters" + items :: [String] <- forM [0..desiredLength] $ \_ -> do + i :: Int <- randomRIO (0, pred alphabetSize) + return $ take 1 . drop i $ alphabet + return $ concat items diff --git a/src/Data/Walk.hs b/src/Data/Walk.hs deleted file mode 100644 --- a/src/Data/Walk.hs +++ /dev/null @@ -1,35 +0,0 @@ -{-#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/Text/Pandoc/Readers/CustomCreole.hs b/src/Text/Pandoc/Readers/CustomCreole.hs new file mode 100644 --- /dev/null +++ b/src/Text/Pandoc/Readers/CustomCreole.hs @@ -0,0 +1,284 @@ +module Text.Pandoc.Readers.CustomCreole +( readCustomCreole +, onLeft +, onRight +) +where + +import Text.Pandoc +import Text.Pandoc.Error +import Text.Parsec +import Data.List (intersperse, intercalate, lookup) +import Data.Maybe (fromMaybe) + +onLeft :: (a -> b) -> Either a c -> Either b c +onLeft f (Left x) = Left (f x) +onLeft _ (Right r) = Right r + +onRight :: (b -> c) -> Either a b -> Either a c +onRight f (Right x) = Right (f x) +onRight _ (Left r) = Left r + +readCustomCreole :: ReaderOptions -> String -> Either PandocError Pandoc +readCustomCreole options input = + onLeft (PandocParsecError input) $ + runParser wikipage () "creole source" input + +wikipage = Pandoc nullMeta <$> (spaces *> manyTill paragraph eof) + +paragraph = nowikiBlock + <|> division nullAttr + <|> horizontalLine + <|> heading nullAttr + <|> annotatedParagraph + <|> emptyParagraph + <|> unorderedList 1 + -- <|> orderedList + <|> textParagraph + +unorderedList level = BulletList <$> many1 (unorderedListItem level) + +unorderedListItem level = do + unorderedListBullet level + unorderedListItemContent level + +unorderedListBullet level = do + try (lookAhead $ char '*') + try (count level (char '*') *> whitespace1) + +unorderedListItemContent :: Int -> Parsec String () [Block] +unorderedListItemContent level = + (:) <$> textItem <*> many anyItem + where + textItem = Para . concat <$> many1 (unorderedListLine level) + anyItem = unorderedList (succ level) <|> textItem + +unorderedListLine level = do + notFollowedBy $ + (ignore . try $ many1 (char '*') *> whitespace1) <|> + (ignore . try $ whitespace *> string "----") <|> + (ignore . try $ whitespace *> char '=') <|> + (ignore . try $ whitespace *> string "]]]" *> notFollowedBy (char ']')) <|> + (ignore eol) <|> + (ignore eof) + many1 (notFollowedBy eol *> textItem) <* (eol <|> eof) + +annotatedParagraph = do + attr <- try preAnnotation + division attr <|> heading attr + +annotation = do + string "@(" + whitespace + kvp <- sepBy attribute (char ',') + let idVal = fromMaybe "" . lookup "id" $ kvp + classes = words . fromMaybe "" . lookup "class" $ kvp + kvp' = [ (k,v) | (k,v) <- kvp, k /= "id" && k /= "class" ] + char ')' + return (idVal, classes, kvp') + where + attribute = do + k <- many (noneOf ")= \t\r\n") + whitespace + char '=' + whitespace + v <- many (noneOf "),\r\n") + whitespace + return (k,v) + +preAnnotation = annotation <* char ':' <* (eol <|> eof) + +postAnnotation = optional eol *> annotation <* notFollowedBy (char ':') + +heading attr = do + leader <- many1 (char '=') + whitespace + inner <- manyTill textItem endOfHeading + attr' <- option attr (try postAnnotation) + return $ Header (length leader) attr' inner + +endOfHeading = eof + <|> try + (do + whitespace + many (char '=') + whitespace + ignore eol <|> eof + ) + +division attr = do + try (string "[[[" *> (eol <|> eof)) + inner <- manyTill paragraph endOfDiv + return $ Div attr inner + +endOfDiv = eof + <|> try + (do + whitespace + string "]]]" + notFollowedBy (char ']') + whitespace + ignore eol <|> eof + ) + +nowikiBlock = do + try (string "{{{" *> (eol <|> eof)) + lns <- many nowikiLine + string "}}}" *> (eol <|> eof) + return $ CodeBlock nullAttr (intercalate "\n" lns) + +nowikiLine = nowikiEscapedEndMarker <|> nowikiRegularLine + +nowikiEscapedEndMarker = try $ do + oneOf " \t" + many (noneOf "\r\n") <* (eol <|> eof) + +nowikiRegularLine = do + notFollowedBy . try $ string "}}}" *> (eol <|> eof) + many (noneOf "\r\n") <* (eol <|> eof) + + +emptyParagraph = try (endOfParagraph *> return Null) + +horizontalLine = try (string "----") *> (eol <|> eof) *> return HorizontalRule + +textParagraph = Para . concat . intersperse [Space] <$> + many1 textLine <* endOfParagraph + +textLine = do + notFollowedBy $ + (ignore . try $ unorderedListBullet 1) <|> + (ignore . try $ whitespace *> string "----") <|> + (ignore . try $ whitespace *> char '=') <|> + (ignore . try $ whitespace *> string "]]]" *> notFollowedBy (char ']')) <|> + (ignore eol) <|> + (ignore eof) + many1 (notFollowedBy eol *> textItem) <* (eol <|> eof) + +textItem = + nowikiTextItem <|> + newlineTextItem <|> + link <|> + image <|> + boldTextItem <|> + italTextItem <|> + whitespaceTextItem <|> + rawTextItem + +link = do + try $ string "[[" *> notFollowedBy (char '[') + url <- many $ noneOf "|]" + label <- option url $ do + char '|' + many $ noneOf "]" + string "]]" + attr <- option nullAttr (try postAnnotation) + return $ Link attr [ Str label ] (url, label) + +image = do + try $ string "{{" *> notFollowedBy (char '{') + url <- many $ noneOf "|}" + label <- option url $ do + char '|' + many $ noneOf "}" + string "}}" + attr <- option nullAttr (try postAnnotation) + return $ Image attr [ Str label ] (url, label) + +newlineTextItem = do + try $ whitespace *> string "\\\\" + whitespace + optional eol + whitespace + return LineBreak + +boldTextItem = Strong <$> + ( + try (string "**" *> notFollowedBy whitespace1) *> + many1 boldItalTextItem <* + ( + eof <|> + (lookAhead . try $ eol *> endOfParagraph) <|> + (ignore . try . string $ "**") + ) + ) + +italTextItem = Emph <$> + ( + try (string "//") *> + many1 italBoldTextItem <* + ( + eof <|> + (lookAhead . try $ eol *> endOfParagraph) <|> + (ignore . try . string $ "//") + ) + ) + + +boldItalTextItem = + nowikiTextItem <|> + newlineTextItem <|> + link <|> + image <|> + italTextItem <|> + whitespaceTextItem <|> + rawTextItem + +italBoldTextItem = + nowikiTextItem <|> + newlineTextItem <|> + link <|> + image <|> + boldTextItem <|> + whitespaceTextItem <|> + rawTextItem + +rawTextItem = Str <$> many1 textChar + +whitespaceTextItem = Space <$ many1 irrelevantWhitespace + +irrelevantWhitespace = + (ignore . many1) (oneOf " \t") <|> try (eol *> notFollowedBy eol) + +nowikiTextItem = + Code nullAttr <$> + (inlineNowikiStart *> manyTill inlineNowikiItem inlineNowikiEnd) + +inlineNowikiEnd = try (string "}}}" *> notFollowedBy (char '}')) + +inlineNowikiStart = try (string "{{{") + +inlineNowikiItem = anyChar + +textChar = escapedChar <|> safeChar <|> allowedSpecialChar + +escapedChar = char '~' *> anyChar + +safeChar = noneOf " \n\r\t~*/[]\\{}@" + +allowedSpecialChar = + try (char '/' <* notFollowedBy (char '/')) <|> + try (char '*' <* notFollowedBy (char '*')) <|> + try (char '[' <* notFollowedBy (char '[')) <|> + try (char '{' <* notFollowedBy (char '{')) <|> + try (char '\\' <* notFollowedBy (char '\\')) <|> + try (char ']' <* notFollowedBy (char ']')) <|> + try (char '}' <* notFollowedBy (char '}')) <|> + try (char '@' <* notFollowedBy (char '(')) + +eol = (try (string "\r\n") <|> string "\n") *> return () + +whitespaceChar = oneOf " \t" + +whitespace1 = many1 whitespaceChar + +whitespace = many whitespaceChar + +ignore :: Parsec s u a -> Parsec s u () +ignore = (*> return ()) + +endOfParagraph = (ignore . lookAhead . try $ whitespace *> string "----") + <|> (ignore . lookAhead . try $ whitespace *> char '=') + <|> (ignore . lookAhead . try $ whitespace *> string "]]]" *> notFollowedBy (char ']')) + <|> ignore eof + <|> ignore eol diff --git a/src/Web/Sprinkles.hs b/src/Web/Sprinkles.hs --- a/src/Web/Sprinkles.hs +++ b/src/Web/Sprinkles.hs @@ -5,11 +5,13 @@ , ServerConfig (..) , loadServerConfig , ServerDriver (..) +, bakeProject ) where -import ClassyPrelude +import Web.Sprinkles.Prelude import Web.Sprinkles.Project import Web.Sprinkles.ServerConfig import Web.Sprinkles.Serve +import Web.Sprinkles.Bake diff --git a/src/Web/Sprinkles/Backends.hs b/src/Web/Sprinkles/Backends.hs --- a/src/Web/Sprinkles/Backends.hs +++ b/src/Web/Sprinkles/Backends.hs @@ -10,7 +10,8 @@ module Web.Sprinkles.Backends ( -- * Defining backends - BackendSpec + BackendSpec (..) +, makeBackendSpecPathsAbsolute , parseBackendURI -- * Fetching backend data , BackendData (..) @@ -23,7 +24,7 @@ ) where -import ClassyPrelude +import Web.Sprinkles.Prelude import System.Random.Shuffle (shuffleM) import Web.Sprinkles.Cache import qualified Data.Serialize as Cereal @@ -33,6 +34,7 @@ import Web.Sprinkles.Backends.Spec ( BackendSpec (..) + , makeBackendSpecPathsAbsolute , BackendType (..) , AscDesc (..) , FetchMode (..) @@ -57,7 +59,8 @@ , rawToLBS ) import Web.Sprinkles.Backends.Loader -import Web.Sprinkles.Backends.Loader.Type (PostBodySource) +import Web.Sprinkles.Backends.Loader.Type (RequestContext (..)) +import Data.Expandable -- | Cache for raw backend data, stored as bytestrings. type RawBackendCache = Cache ByteString ByteString @@ -68,23 +71,24 @@ -- | Execute a backend query, with caching. loadBackendData :: Monad m => (LogLevel -> Text -> IO ()) - -> PostBodySource + -> RequestContext -> RawBackendCache -> BackendSpec - -> IO (Items (BackendData m h)) -loadBackendData writeLog cache loadPost bspec = + -> IO (Items (BackendData p m h)) +loadBackendData writeLog context cache bspec = fmap (reduceItems (bsFetchMode bspec)) $ - fetchBackendData writeLog cache loadPost bspec >>= + fetchBackendData writeLog context cache' bspec >>= mapM parseBackendData >>= sorter where - sorter :: [BackendData m h] -> IO [BackendData m h] + cache' = if bsCacheEnabled bspec then cache else mempty + sorter :: [BackendData p m h] -> IO [BackendData p 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 :: [BackendData p m h] -> IO [BackendData p m h] baseSorter = case fetchField (bsOrder bspec) of ArbitraryOrder -> return RandomOrder -> shuffleM @@ -102,7 +106,7 @@ (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 :: (LogLevel -> Text -> IO ()) -> RequestContext -> RawBackendCache -> BackendSpec -> IO [BackendSource] fetchBackendData writeLog loadPost rawCache spec = cacheWrap (fetchBackendData' writeLog loadPost) spec where @@ -113,11 +117,11 @@ cache = wrapBackendCache rawCache -- | Fetch raw backend data from a backend source, without caching. -fetchBackendData' :: (LogLevel -> Text -> IO ()) -> PostBodySource -> BackendSpec -> IO [BackendSource] +fetchBackendData' :: (LogLevel -> Text -> IO ()) -> RequestContext -> BackendSpec -> IO [BackendSource] fetchBackendData' writeLog loadPost - (BackendSpec backendType fetchMode fetchOrder mimeOverride) = + (BackendSpec backendType fetchMode fetchOrder mimeOverride _) = map (overrideMime mimeOverride) <$> loader backendType writeLog loadPost fetchMode fetchOrder overrideMime :: Maybe MimeType -> BackendSource -> BackendSource diff --git a/src/Web/Sprinkles/Backends/Data.hs b/src/Web/Sprinkles/Backends/Data.hs --- a/src/Web/Sprinkles/Backends/Data.hs +++ b/src/Web/Sprinkles/Backends/Data.hs @@ -6,12 +6,15 @@ {-#LANGUAGE FlexibleContexts #-} {-#LANGUAGE LambdaCase #-} {-#LANGUAGE DeriveGeneric #-} +{-#LANGUAGE DeriveFunctor #-} +{-#LANGUAGE TypeApplications #-} -- | Types for and operations on backend data. module Web.Sprinkles.Backends.Data ( BackendData (..) , BackendMeta (..) , BackendSource (..) +, Verification (..) , RawBytes (..) , toBackendData , Items (..) @@ -24,7 +27,7 @@ ) where -import ClassyPrelude +import Web.Sprinkles.Prelude import Text.Ginger (ToGVal (..), GVal, Run (..), dict, (~>)) import qualified Text.Ginger as Ginger import Data.Aeson as JSON @@ -38,6 +41,10 @@ import Data.Time.Clock.POSIX (POSIXTime, posixSecondsToUTCTime) import Data.Time (UTCTime, LocalTime, utc, utcToLocalTime) import Data.Scientific (Scientific) +import qualified Data.ByteString.Char8 as BS8 +import qualified Data.ByteString.Lazy.Char8 as LBS8 +import Text.Printf (printf) +import Data.Foldable (Foldable (foldMap)) import Web.Sprinkles.Backends.Spec @@ -49,7 +56,13 @@ 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 + deriving (Functor) +instance Foldable Items where + foldMap f NotFound = mempty + foldMap f (SingleItem x) = f x + foldMap f (MultiItem xs) = mconcat $ map f xs + -- | 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 @@ -94,21 +107,79 @@ len <- rbLength r rbGetRange r 0 len +rawToGVal :: MonadIO m => RawBytes -> GVal (Run p m h) +rawToGVal raw = + dict + [ ("length", Ginger.fromFunction (gfnLength raw)) + , ("read", Ginger.fromFunction (gfnRead raw)) + , ("store", Ginger.fromFunction (gfnStore raw)) + ] + where + gfnLength :: MonadIO m => RawBytes -> [(Maybe Text, GVal (Run p m h))] -> Run p m h (GVal (Run p m h)) + gfnLength raw args = do + length <- liftIO (rbLength raw) + return . toGVal $ length + gfnRead :: MonadIO m => RawBytes -> [(Maybe Text, GVal (Run p m h))] -> Run p m h (GVal (Run p m h)) + gfnRead raw args = do + inputLength <- liftIO (rbLength raw) + let extracted = + Ginger.extractArgsDefL + [ ("start", def) + , ("length", toGVal inputLength) + ] + args + case extracted of + Right [startG, lengthG] -> do + let start = fromMaybe 0 $ asInteger startG + length = fromMaybe inputLength $ asInteger lengthG + bytes <- liftIO (rbGetRange raw start length) + return . toGVal . LBS8.unpack $ bytes + _ -> fail "Invalid arguments to RawBytes.read" + + gfnStore :: MonadIO m => RawBytes -> [(Maybe Text, GVal (Run p m h))] -> Run p m h (GVal (Run p m h)) + gfnStore raw args = do + let extracted = + Ginger.extractArgsDefL + [ ("filename", "stored") + ] + args + case extracted of + Right [filenameG] -> liftIO $ do + let filename = unpack . Ginger.asText $ filenameG + len <- rbLength raw + bytes <- rbGetRange raw 0 len + LBS8.writeFile filename bytes + return . toGVal $ True + _ -> fail "Invalid arguments to RawBytes.store" + + asInteger :: GVal m -> Maybe Integer + asInteger = fmap round . Ginger.asNumber + +instance MonadIO m => ToGVal (Run p m h) RawBytes where + toGVal = rawToGVal + -- | A parsed record from a query result. -data BackendData m h = +data BackendData p m h = BackendData { bdJSON :: JSON.Value -- ^ Result body as JSON - , bdGVal :: GVal (Run m h) -- ^ Result body as GVal + , bdGVal :: GVal (Run p m h) -- ^ Result body as GVal , bdRaw :: RawBytes -- ^ Raw result body source , bdMeta :: BackendMeta -- ^ Meta-information - , bdChildren :: HashMap Text (BackendData m h) -- ^ Child documents + , bdChildren :: HashMap Text (BackendData p m h) -- ^ Child documents + , bdVerification :: Verification } +data Verification + = Trusted + | VerifyCSRF + deriving (Show, Eq, Enum, Ord, Bounded) + -- | A raw (unparsed) record from a query result. data BackendSource = BackendSource { bsMeta :: BackendMeta , bsSource :: RawBytes + , bsVerification :: Verification } deriving (Generic) @@ -128,13 +199,13 @@ deserializeBackendSource :: SerializableBackendSource -> BackendSource deserializeBackendSource sbs = - BackendSource (sbsMeta sbs) (rawFromLBS $ sbsSource sbs) + BackendSource (sbsMeta sbs) (rawFromLBS $ sbsSource sbs) Trusted -- | 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 :: (ToJSON a, ToGVal (Run p m h) a) => BackendSource -> a -> BackendData p m h toBackendData src val = BackendData { bdJSON = toJSON val @@ -142,18 +213,19 @@ , bdRaw = bsSource src , bdMeta = bsMeta src , bdChildren = mapFromList [] + , bdVerification = bsVerification src } -addBackendDataChildren :: HashMap Text (BackendData m h) - -> BackendData m h - -> BackendData m h +addBackendDataChildren :: HashMap Text (BackendData p m h) + -> BackendData p m h + -> BackendData p m h addBackendDataChildren children bd = bd { bdChildren = children <> bdChildren bd } -instance ToJSON (BackendData m h) where +instance ToJSON (BackendData p m h) where toJSON = bdJSON -instance ToGVal (Run m h) (BackendData m h) where +instance MonadIO m => ToGVal (Run p m h) (BackendData p m h) where toGVal bd = let baseVal = bdGVal bd baseLookup = fromMaybe (const def) $ Ginger.asLookup baseVal @@ -164,9 +236,11 @@ { Ginger.asLookup = Just $ \case "props" -> return . toGVal . bdMeta $ bd "children" -> return childrenG + "bytes" -> return . toGVal . bdRaw $ bd k -> baseLookup k , Ginger.asDictItems = (("props" ~> bdMeta bd):) . + (("bytes" ~> bdRaw bd):) . (("children", childrenG):) <$> baseDictItems } @@ -207,7 +281,7 @@ toJSON bm = let (mtime, mtimeSci, mtimeUTC) = mtimeFlavors bm in JSON.object - [ "mimeType" .= decodeUtf8 (bmMimeType bm) + [ "mimeType" .= decodeUtf8 @Text (bmMimeType bm) , "mtime" .= mtimeSci , "mtimeUTC" .= mtimeUTC , "name" .= bmName bm @@ -219,7 +293,7 @@ toGVal bm = let (mtime, mtimeSci, mtimeUTC) = mtimeFlavors bm in Ginger.dict - [ "type" ~> decodeUtf8 (bmMimeType bm) + [ "type" ~> decodeUtf8 @Text (bmMimeType bm) , "mtime" ~> mtimeSci , "mtimeUTC" ~> mtimeUTC , "name" ~> bmName bm diff --git a/src/Web/Sprinkles/Backends/Loader.hs b/src/Web/Sprinkles/Backends/Loader.hs --- a/src/Web/Sprinkles/Backends/Loader.hs +++ b/src/Web/Sprinkles/Backends/Loader.hs @@ -12,7 +12,7 @@ ) where -import ClassyPrelude +import Web.Sprinkles.Prelude import Web.Sprinkles.Backends.Loader.Type import Web.Sprinkles.Backends.Loader.SqlLoader import Web.Sprinkles.Backends.Loader.SubprocessLoader @@ -21,9 +21,11 @@ import Web.Sprinkles.Backends.Loader.RequestBodyLoader import Web.Sprinkles.Backends.Loader.LiteralLoader import Web.Sprinkles.Backends.Spec +import Web.Sprinkles.Databases (ResultSetMode (..)) loader :: BackendType -> Loader -loader (SqlBackend dsn query params) = sqlLoader dsn query params +loader (SqlBackend dsn query params) = sqlLoader dsn ResultsLast [(query, params)] +loader (SqlMultiBackend dsn mode queries) = sqlLoader dsn mode queries loader (FileBackend filepath) = fileLoader filepath loader (HttpBackend uriText credentials) = curlLoader uriText credentials loader (SubprocessBackend cmd args mimeType) = subprocessLoader cmd args mimeType diff --git a/src/Web/Sprinkles/Backends/Loader/FileLoader.hs b/src/Web/Sprinkles/Backends/Loader/FileLoader.hs --- a/src/Web/Sprinkles/Backends/Loader/FileLoader.hs +++ b/src/Web/Sprinkles/Backends/Loader/FileLoader.hs @@ -5,6 +5,7 @@ {-#LANGUAGE FlexibleInstances #-} {-#LANGUAGE FlexibleContexts #-} {-#LANGUAGE LambdaCase #-} +{-#LANGUAGE TypeApplications #-} -- | File backend loader module Web.Sprinkles.Backends.Loader.FileLoader @@ -12,11 +13,12 @@ ) where -import ClassyPrelude +import Web.Sprinkles.Prelude import Web.Sprinkles.Backends.Data ( BackendData (..) , BackendMeta (..) , BackendSource (..) + , Verification (..) , Items (..) , reduceItems , RawBytes (..) @@ -64,7 +66,7 @@ else fetchAsFile candidate fetchAsDir candidate = do let mimeType = "application/x-directory" - contents <- (encodeUtf8 . unlines . fmap pack <$> getDirectoryContents candidate) + contents <- (encodeUtf8 @LText . unlines . fmap pack <$> getDirectoryContents candidate) `catchIOError` \err -> do writeLog Notice $ tshow err return "" @@ -102,7 +104,7 @@ , bmPath = pack candidate , bmSize = Just . fromIntegral $ fileSize status :: Maybe Integer } - return $ BackendSource meta contents + return $ BackendSource meta contents Trusted -- | 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. diff --git a/src/Web/Sprinkles/Backends/Loader/HttpLoader.hs b/src/Web/Sprinkles/Backends/Loader/HttpLoader.hs --- a/src/Web/Sprinkles/Backends/Loader/HttpLoader.hs +++ b/src/Web/Sprinkles/Backends/Loader/HttpLoader.hs @@ -5,6 +5,7 @@ {-#LANGUAGE FlexibleInstances #-} {-#LANGUAGE FlexibleContexts #-} {-#LANGUAGE LambdaCase #-} +{-#LANGUAGE TypeApplications #-} -- | HTTP backend loader module Web.Sprinkles.Backends.Loader.HttpLoader @@ -12,7 +13,7 @@ ) where -import ClassyPrelude +import Web.Sprinkles.Prelude import Web.Sprinkles.Backends.Spec ( HttpBackendOptions (..) ) @@ -20,6 +21,7 @@ ( BackendData (..) , BackendMeta (..) , BackendSource (..) + , Verification (..) , Items (..) , reduceItems , rawFromLBS @@ -39,7 +41,7 @@ curlLoader :: Text -> HttpBackendOptions -> Loader curlLoader uriText options writeLog _ fetchMode fetchOrder = do - let accepts = intercalate "," . map (unpack . decodeUtf8) $ httpAcceptedContentTypes options + let accepts = intercalate "," . map (unpack . decodeUtf8 @Text) $ httpAcceptedContentTypes options writeLog Debug $ "cURL " <> uriText Curl.initialize >>= \curl -> do response <- Curl.curlGetResponse_ @@ -59,7 +61,7 @@ getHeader hname = lookup hname headers getHeaderDef def = fromMaybe def . getHeader mimeType = encodeUtf8 $ getHeaderDef "text/plain" "content-type" - contentLength = readMay . unpack =<< getHeader "content-length" + contentLength = readMay =<< getHeader "content-length" writeLog Debug $ (pack . show) (Curl.respCurlCode response) writeLog Debug $ pack (Curl.respStatusLine response) writeLog Debug $ "Content-type: " <> decodeUtf8 mimeType @@ -78,4 +80,4 @@ , bmPath = uriText , bmSize = contentLength } - return [BackendSource meta body] + return [BackendSource meta body Trusted] diff --git a/src/Web/Sprinkles/Backends/Loader/LiteralLoader.hs b/src/Web/Sprinkles/Backends/Loader/LiteralLoader.hs --- a/src/Web/Sprinkles/Backends/Loader/LiteralLoader.hs +++ b/src/Web/Sprinkles/Backends/Loader/LiteralLoader.hs @@ -12,11 +12,12 @@ ) where -import ClassyPrelude +import Web.Sprinkles.Prelude import Web.Sprinkles.Backends.Data ( BackendData (..) , BackendMeta (..) , BackendSource (..) + , Verification (..) , Items (..) , reduceItems , RawBytes (..) @@ -45,4 +46,4 @@ , bmPath = "literal" , bmSize = Just . fromIntegral $ length rawBodyBytes } - return [ BackendSource meta rawBody ] + return [ BackendSource meta rawBody Trusted ] diff --git a/src/Web/Sprinkles/Backends/Loader/RequestBodyLoader.hs b/src/Web/Sprinkles/Backends/Loader/RequestBodyLoader.hs --- a/src/Web/Sprinkles/Backends/Loader/RequestBodyLoader.hs +++ b/src/Web/Sprinkles/Backends/Loader/RequestBodyLoader.hs @@ -4,7 +4,7 @@ {-#LANGUAGE MultiParamTypeClasses #-} {-#LANGUAGE FlexibleInstances #-} {-#LANGUAGE FlexibleContexts #-} -{-#LANGUAGE LambdaCase #-} +{-#LANGUAGE DeriveGeneric #-} -- | File backend loader module Web.Sprinkles.Backends.Loader.RequestBodyLoader @@ -12,11 +12,12 @@ ) where -import ClassyPrelude +import Web.Sprinkles.Prelude import Web.Sprinkles.Backends.Data ( BackendData (..) , BackendMeta (..) , BackendSource (..) + , Verification (..) , Items (..) , reduceItems , rawFromLBS @@ -32,15 +33,57 @@ , defaultMimeType , FileName ) +import qualified Data.ByteString as BS +import Data.Char (ord) +data Disposition = + Disposition + { baseDisposition :: ByteString + , dispositionAttribs :: [(ByteString, ByteString)] + } + deriving (Show, Eq, Generic) + +trimL :: ByteString -> ByteString +trimL = BS.dropWhile (<= 32) + +trimR :: ByteString -> ByteString +trimR = fst . BS.spanEnd (<= 32) + +trim :: ByteString -> ByteString +trim = trimL . trimR + +stripQuotes :: ByteString -> ByteString +stripQuotes = + BS.takeWhile (/= fromIntegral (ord '"')) . + BS.dropWhile (== fromIntegral (ord '"')) + +parseDisposition :: ByteString -> Disposition +parseDisposition str = + let base:attribStrs = map trim $ BS.split (fromIntegral . ord $ ';') str + attribs = concatMap parseAttrib attribStrs + in Disposition base attribs + where + parseAttrib :: ByteString -> [(ByteString, ByteString)] + parseAttrib str = + case BS.split (fromIntegral . ord $ '=') str of + [name, value] -> + [(trim name, stripQuotes . trim $ value)] + _ -> [] + requestBodyLoader :: Loader requestBodyLoader writeLog pbs fetchMode fetchOrder = do contents <- rawFromLBS <$> loadPost pbs + let disposition = + fromMaybe (Disposition "attachment" []) $ + parseDisposition <$> lookupHeader pbs "Content-Disposition" + filename = fromMaybe "POST" $ + lookup "filename" (dispositionAttribs disposition) + writeLog Debug . pack . show $ disposition let meta = BackendMeta { bmMimeType = contentType pbs , bmMTime = Nothing , bmName = "POST" - , bmPath = "POST" + , bmPath = decodeUtf8 filename , bmSize = Nothing } - return [BackendSource meta contents] + return [BackendSource meta contents VerifyCSRF] diff --git a/src/Web/Sprinkles/Backends/Loader/SqlLoader.hs b/src/Web/Sprinkles/Backends/Loader/SqlLoader.hs --- a/src/Web/Sprinkles/Backends/Loader/SqlLoader.hs +++ b/src/Web/Sprinkles/Backends/Loader/SqlLoader.hs @@ -12,11 +12,12 @@ ) where -import ClassyPrelude +import Web.Sprinkles.Prelude import Web.Sprinkles.Backends.Data ( BackendData (..) , BackendMeta (..) , BackendSource (..) + , Verification (..) , Items (..) , reduceItems , rawFromLBS @@ -29,23 +30,35 @@ import Data.Aeson.TH as JSON import Data.Yaml as YAML import Web.Sprinkles.Backends.Loader.Type +import Data.List.Extra (takeEnd) -sqlLoader :: DSN -> Text -> [Text] -> Loader -sqlLoader dsn query params writeLog _ fetchMode fetchOrder = do - rows <- DB.withConnection dsn $ \conn -> do +sqlLoader :: DSN -> DB.ResultSetMode -> [(Text, [Text])] -> Loader +sqlLoader dsn mode queries writeLog _ fetchMode fetchOrder = do + resultSets <- 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 + forM queries $ \(query, params) -> 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 $ mergeResultSets resultSets where + mergeResultSets :: [[Map String HDBC.SqlValue]] -> [BackendSource] + mergeResultSets [] = [] + mergeResultSets rawRows = case mode of + DB.ResultsMerge -> + map mapRow . mconcat $ rawRows + DB.ResultsNth i -> + map mapRow . mconcat . drop i . take 1 $ rawRows + DB.ResultsLast -> + map mapRow . mconcat . takeEnd 1 $ rawRows + mapRow :: Map String HDBC.SqlValue -> BackendSource mapRow row = - let json = JSON.encode (fmap (HDBC.fromSql :: HDBC.SqlValue -> Text) row) + let json = JSON.encode (fmap (HDBC.fromSql :: HDBC.SqlValue -> Maybe Text) row) name = maybe "SQL" HDBC.fromSql $ lookup "name" row <|> lookup "title" row <|> @@ -57,4 +70,4 @@ , bmPath = "SQL" , bmSize = Just . fromIntegral $ length json } - in BackendSource meta (rawFromLBS json) + in BackendSource meta (rawFromLBS json) Trusted diff --git a/src/Web/Sprinkles/Backends/Loader/SubprocessLoader.hs b/src/Web/Sprinkles/Backends/Loader/SubprocessLoader.hs --- a/src/Web/Sprinkles/Backends/Loader/SubprocessLoader.hs +++ b/src/Web/Sprinkles/Backends/Loader/SubprocessLoader.hs @@ -12,11 +12,12 @@ ) where -import ClassyPrelude +import Web.Sprinkles.Prelude import Web.Sprinkles.Backends.Data ( BackendData (..) , BackendMeta (..) , BackendSource (..) + , Verification (..) , Items (..) , reduceItems , rawFromLBS @@ -40,4 +41,4 @@ , bmPath = unwords $ cmd:args , bmSize = Just contentLength } - return [BackendSource meta (rawFromLBS body)] + return [BackendSource meta (rawFromLBS . fromStrict $ body) Trusted] diff --git a/src/Web/Sprinkles/Backends/Loader/Type.hs b/src/Web/Sprinkles/Backends/Loader/Type.hs --- a/src/Web/Sprinkles/Backends/Loader/Type.hs +++ b/src/Web/Sprinkles/Backends/Loader/Type.hs @@ -10,8 +10,11 @@ module Web.Sprinkles.Backends.Loader.Type where -import ClassyPrelude +import Web.Sprinkles.Prelude import qualified Network.Wai as Wai +import Network.HTTP.Types (HeaderName) +import Web.Sprinkles.SessionHandle (SessionHandle) +import Debug.Trace (trace) import Web.Sprinkles.Backends.Data ( BackendData (..) @@ -26,30 +29,36 @@ ) import Web.Sprinkles.Logger (LogLevel) -data PostBodySource = - PostBodySource +data RequestContext = + RequestContext { loadPost :: IO LByteString - , contentType :: ByteString + , sessionHandle :: Maybe SessionHandle + , lookupHeader :: HeaderName -> Maybe ByteString } +contentType :: RequestContext -> ByteString +contentType rqc = fromMaybe "text/plain" $ lookupHeader rqc "Content-type" + type Loader = (LogLevel -> Text -> IO ()) - -> PostBodySource + -> RequestContext -> FetchMode -> FetchOrder -> IO [BackendSource] -pbsFromRequest :: Wai.Request -> PostBodySource -pbsFromRequest request = - PostBodySource +pbsFromRequest :: Wai.Request -> Maybe SessionHandle -> RequestContext +pbsFromRequest request session = + RequestContext { loadPost = Wai.lazyRequestBody request - , contentType = fromMaybe "text/plain" $ - lookup "Content-type" (Wai.requestHeaders request) + , sessionHandle = session + , lookupHeader = \name -> + lookup name (Wai.requestHeaders request) } -pbsInvalid :: PostBodySource +pbsInvalid :: RequestContext pbsInvalid = - PostBodySource + RequestContext { loadPost = fail "POST body not available" - , contentType = "text/plain" + , sessionHandle = Nothing + , lookupHeader = const Nothing } diff --git a/src/Web/Sprinkles/Backends/Parsers.hs b/src/Web/Sprinkles/Backends/Parsers.hs --- a/src/Web/Sprinkles/Backends/Parsers.hs +++ b/src/Web/Sprinkles/Backends/Parsers.hs @@ -6,6 +6,7 @@ {-#LANGUAGE FlexibleContexts #-} {-#LANGUAGE LambdaCase #-} {-#LANGUAGE TupleSections #-} +{-#LANGUAGE TypeApplications #-} -- | Parse raw backend data into useful data structures. module Web.Sprinkles.Backends.Parsers @@ -13,12 +14,13 @@ ) where -import ClassyPrelude +import Web.Sprinkles.Prelude import Web.Sprinkles.Backends.Data ( BackendData (..) , BackendMeta (..) , BackendSource (..) + , Verification (..) , toBackendData , addBackendDataChildren , rawToLBS, rawFromLBS @@ -27,7 +29,8 @@ ( parserTypes , ParserType (..) ) -import Text.Pandoc (Pandoc) +import Web.Sprinkles.Pandoc (pandocReaderOptions) +import Text.Pandoc (Pandoc, PandocPure) import qualified Text.Pandoc as Pandoc import qualified Text.Pandoc.MediaBag as Pandoc import qualified Text.Pandoc.Readers.Creole as Pandoc @@ -44,38 +47,38 @@ -- | 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 + -> m (BackendData p 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)) + => HashMap MimeType (BackendSource -> m (BackendData p 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))] + => [([MimeType], BackendSource -> m (BackendData p n h))] parsers = [ (types, getParser p) | (types, p) <- parserTypes ] getParser :: (MonadIO m, Monad m, Monad n) => ParserType - -> (BackendSource -> m (BackendData n h)) + -> (BackendSource -> m (BackendData p 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 ParserMarkdown = pandoc (Pandoc.readMarkdown pandocReaderOptions) +getParser ParserCreole = pandoc (Pandoc.readCreole pandocReaderOptions) +getParser ParserTextile = pandoc (Pandoc.readTextile pandocReaderOptions) +getParser ParserRST = pandoc (Pandoc.readRST pandocReaderOptions) +getParser ParserLaTeX = pandoc (Pandoc.readLaTeX pandocReaderOptions) +getParser ParserDocX = pandocWithMedia (Pandoc.readDocx pandocReaderOptions) getParser ParserText = plainText -getParser ParserHtml = pandoc (Pandoc.readHtml Pandoc.def) +getParser ParserHtml = pandoc (Pandoc.readHtml pandocReaderOptions) -- | All the content types we know how to parse knownContentTypes :: [MimeType] @@ -83,40 +86,41 @@ -- | 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) = +parseRawData :: Monad m => BackendSource -> m (BackendData p n h) +parseRawData (BackendSource meta body veri) = return BackendData { bdJSON = JSON.Null , bdGVal = toGVal JSON.Null , bdMeta = meta , bdRaw = body , bdChildren = mapFromList [] + , bdVerification = veri } -- | 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 +plainText :: (MonadIO m, Monad m) => BackendSource -> m (BackendData p n h) +plainText item@(BackendSource meta body _) = do + textBody <- liftIO $ toStrict . decodeUtf8 @LText <$> 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 +json :: (MonadIO m, Monad m) => BackendSource -> m (BackendData p 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 +yaml :: (MonadIO m, Monad m) => BackendSource -> m (BackendData p 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 + case YAML.decodeEither' (toStrict bodyBytes) of + Left err -> fail $ YAML.prettyPrintParseException 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 +urlencodedForm :: (MonadIO m, Monad m) => BackendSource -> m (BackendData p n h) +urlencodedForm item@(BackendSource meta body _) = do bodyBytes <- liftIO $ rawToLBS body return . toBackendData item . @@ -131,24 +135,28 @@ -- | Parser for Pandoc-supported formats that are read from 'LByteString's. pandocBS :: (MonadIO m, Monad m, Monad n) - => (LByteString -> Either PandocError Pandoc) + => (LByteString -> PandocPure Pandoc) -> BackendSource - -> m (BackendData n h) -pandocBS reader input@(BackendSource meta body) = do + -> m (BackendData p n h) +pandocBS reader input@(BackendSource meta body _) = do bodyBytes <- liftIO $ rawToLBS body - case reader bodyBytes of + case Pandoc.runPure $ 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)) + => (LByteString -> PandocPure Pandoc) -> BackendSource - -> m (BackendData n h) -pandocWithMedia reader input@(BackendSource meta body) = do + -> m (BackendData p n h) +pandocWithMedia reader input@(BackendSource meta body _) = do bodyBytes <- liftIO $ rawToLBS body - case reader bodyBytes of + let reader' = do + pandoc <- reader bodyBytes + mediaBag <- Pandoc.getMediaBag + return (pandoc, mediaBag) + case Pandoc.runPure reader' of Left err -> fail . show $ err Right (pandoc, mediaBag) -> do -- TODO: marshal mediaBag to backend data item children @@ -158,7 +166,7 @@ mediaBagToBackendData :: (MonadIO m, Monad m, Monad n) => Pandoc.MediaBag - -> m [(Text, BackendData n h)] + -> m [(Text, BackendData p n h)] mediaBagToBackendData bag = do let metas = Pandoc.mediaDirectory bag forM metas $ \(path, mimeType, contentLength) -> do @@ -168,19 +176,19 @@ (Pandoc.lookupMedia path bag) let meta = BackendMeta - { bmMimeType = encodeUtf8 . pack $ mimeType + { bmMimeType = encodeUtf8 . pack @Text $ mimeType , bmMTime = Nothing , bmName = pack path , bmPath = pack path , bmSize = Just $ fromIntegral contentLength } - (pack path,) <$> parseBackendData (BackendSource meta (rawFromLBS body)) + (pack path,) <$> parseBackendData (BackendSource meta (rawFromLBS body) Trusted) -- | Parser for Pandoc-supported formats that are read from 'String's. pandoc :: (MonadIO m, Monad m, Monad n) - => (String -> Either PandocError Pandoc) + => (Text -> PandocPure Pandoc) -> BackendSource - -> m (BackendData n h) + -> m (BackendData p n h) pandoc reader = - pandocBS (reader . unpack . decodeUtf8) + pandocBS (reader . toStrict . decodeUtf8) diff --git a/src/Web/Sprinkles/Backends/Spec.hs b/src/Web/Sprinkles/Backends/Spec.hs --- a/src/Web/Sprinkles/Backends/Spec.hs +++ b/src/Web/Sprinkles/Backends/Spec.hs @@ -1,17 +1,23 @@ {-#LANGUAGE NoImplicitPrelude #-} {-#LANGUAGE OverloadedStrings #-} +{-#LANGUAGE OverloadedLists #-} {-#LANGUAGE TypeFamilies #-} {-#LANGUAGE MultiParamTypeClasses #-} {-#LANGUAGE FlexibleInstances #-} {-#LANGUAGE FlexibleContexts #-} {-#LANGUAGE LambdaCase #-} +{-#LANGUAGE TupleSections #-} {-#LANGUAGE DeriveGeneric #-} +{-#LANGUAGE TypeApplications #-} -- | Backend spec types and parser module Web.Sprinkles.Backends.Spec ( -- * Defining backends BackendSpec (..) +, backendSpecFromJSON +, makeBackendTypePathsAbsolute +, makeBackendSpecPathsAbsolute , BackendType (..) , FetchOrderField (..) , FetchMode (..) @@ -28,77 +34,111 @@ ) where -import ClassyPrelude +import Web.Sprinkles.Prelude import Network.Mime (MimeType) import Network.HTTP.Types () import Data.Aeson (FromJSON (..), Value (..), (.=), (.!=), (.:?), (.:)) import qualified Data.Aeson as JSON +import qualified Data.Aeson.Types 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.Databases (DSN (..), sqlDriverFromID, ResultSetMode (..)) import Web.Sprinkles.Logger (LogLevel (..)) -import Data.Walk (walk) +import Data.Expandable (ExpandableM (..), expand) -- | 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 + | SqlMultiBackend DSN ResultSetMode [(Text, [Text])] -- ^ Query an SQL database, multiple queries | 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) +makeBackendTypePathsAbsolute :: FilePath -> BackendType -> BackendType +makeBackendTypePathsAbsolute dir (FileBackend fn) = FileBackend (pack . (dir ) . unpack $ fn) +makeBackendTypePathsAbsolute dir (SubprocessBackend cmd args ty) = SubprocessBackend (pack . (dir ) . unpack $ cmd) args ty +makeBackendTypePathsAbsolute _ x = x + instance Serialize BackendType where put (HttpBackend url options) = do Cereal.put 'h' - Cereal.put (encodeUtf8 . unpack $ url) + Cereal.put (encodeUtf8 url) Cereal.put options put (FileBackend path) = do Cereal.put 'f' - Cereal.put (encodeUtf8 . unpack $ path) + Cereal.put (encodeUtf8 path) put (SqlBackend dsn query params) = do Cereal.put 's' Cereal.put dsn - Cereal.put (encodeUtf8 . unpack $ query) - Cereal.put (map (encodeUtf8 . unpack) params) + Cereal.put (encodeUtf8 query) + Cereal.put (map encodeUtf8 params) + put (SqlMultiBackend dsn mode queries) = do + Cereal.put 'S' + Cereal.put dsn + Cereal.put mode + Cereal.put + [ (encodeUtf8 $ q, map encodeUtf8 p) + | (q, p) <- queries + ] put (SubprocessBackend cmd args t) = do Cereal.put 'p' - Cereal.put (encodeUtf8 . unpack $ cmd) - Cereal.put (map (encodeUtf8 . unpack) args) + Cereal.put (encodeUtf8 cmd) + Cereal.put (map encodeUtf8 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) + 'h' -> HttpBackend <$> (decodeUtf8 <$> Cereal.get) <*> Cereal.get + 'f' -> FileBackend <$> (decodeUtf8 <$> Cereal.get) 's' -> SqlBackend <$> Cereal.get <*> - (pack . decodeUtf8 <$> Cereal.get) <*> - (map (pack . decodeUtf8) <$> Cereal.get) + (decodeUtf8 <$> Cereal.get) <*> + (map decodeUtf8 <$> Cereal.get) + 'S' -> SqlMultiBackend <$> + Cereal.get <*> + Cereal.get <*> + (Cereal.get >>= \items -> return + [ ( decodeUtf8 q + , map decodeUtf8 p + ) + | (q, p) <- items + ]) 'p' -> SubprocessBackend <$> - (pack . decodeUtf8 <$> Cereal.get) <*> - (map (pack . decodeUtf8) <$> Cereal.get) <*> + (decodeUtf8 <$> Cereal.get) <*> + (map 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) +instance ExpandableM Text BackendType where + expandM f (HttpBackend t c) = + HttpBackend <$> f t <*> pure c + expandM f (FileBackend t) = + FileBackend <$> f t + expandM f (SqlBackend dsn query params) = + SqlBackend <$> expandM f dsn <*> pure query <*> expandM f params + expandM f (SqlMultiBackend dsn mode queries) = + SqlMultiBackend + <$> expandM f dsn + <*> pure mode + <*> ( forM queries $ \(query, params) -> + (query,) <$> expandM f params + ) + expandM f (SubprocessBackend cmd args t) = + SubprocessBackend cmd <$> expandM f args <*> pure t + expandM _ RequestBodyBackend = + pure RequestBodyBackend + expandM f (LiteralBackend b) = + LiteralBackend <$> expandM f b -- | A specification of a backend query. data BackendSpec = @@ -108,15 +148,23 @@ , bsOrder :: FetchOrder -- ^ How to order items -- | If set, ignore reported MIME type and use this one instead. , bsMimeTypeOverride :: Maybe MimeType + , bsCacheEnabled :: Bool } deriving (Show, Generic) instance Serialize BackendSpec -type instance Element BackendSpec = Text +makeBackendSpecPathsAbsolute :: FilePath -> BackendSpec -> BackendSpec +makeBackendSpecPathsAbsolute dir spec = + spec { bsType = makeBackendTypePathsAbsolute dir (bsType spec) } -instance MonoFunctor BackendSpec where - omap f (BackendSpec t m o mto) = BackendSpec (omap f t) m o mto +instance ExpandableM Text BackendSpec where + expandM f (BackendSpec t m o mto ce) = + BackendSpec <$> expandM f t + <*> pure m + <*> pure o + <*> pure mto + <*> pure ce -- | The JSON shape of a backend spec is: -- @@ -165,6 +213,7 @@ parseJSON = backendSpecFromJSON -- | Read a backend spec from a JSON value. +backendSpecFromJSON :: JSON.Value -> JSON.Parser BackendSpec backendSpecFromJSON (String uri) = parseBackendURI uri backendSpecFromJSON (Object obj) = do @@ -182,23 +231,50 @@ 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 + cacheEnabled <- obj .:? "cache-enabled" .!= True + mimeOverride <- fmap encodeUtf8 . (id @(Maybe Text)) <$> obj .:? "force-mime-type" + return $ BackendSpec t fetchMode fetchOrder mimeOverride cacheEnabled where parseHttpBackendSpec = do t <- obj .: "uri" return (HttpBackend t def, FetchOne) parseFileBackendSpec m = do path <- obj .: "path" - return (FileBackend (pack path), m) + return (FileBackend 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) + case lookup "queries" obj of + Nothing -> do + query <- obj .: "query" + params <- obj .:? "params" .!= [] + return (SqlBackend dsn query params, FetchAll) + Just (Array queries') -> do + queries <- forM (toList queries') $ \case + String queryStr -> do + return (queryStr, []) + Object queriesObj -> do + query <- queriesObj .: "query" + params <- queriesObj .:? "params" .!= [] + return (query, params) + Array queriesArr -> do + case toList queriesArr of + [] -> + fail "Invalid query object, empty array is not allowed" + [String queryStr] -> + return (queryStr, []) + [String queryStr, Array params] -> + (queryStr,) <$> mapM parseJSON (toList params) + (String queryStr:params) -> + (queryStr,) <$> mapM parseJSON params + x -> + fail "Invalid query object, first array element must be string" + x -> fail "Invalid query object, must be array, string, or object" + mode <- obj .:? "results" .!= ResultsMerge + return (SqlMultiBackend dsn mode queries, FetchAll) + Just x -> fail "Invalid queries object, must be array" parseSubprocessSpec = do rawCmd <- obj .: "cmd" t <- fromString <$> (obj .:? "mime-type" .!= "text/plain") @@ -206,7 +282,8 @@ 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" + _ -> fail "Expected a command and a list of arguments" + x -> fail $ "Expected string or array, but found " ++ show x parseLiteralBackendSpec = do b <- obj .:? "body" .!= JSON.Null return (LiteralBackend b, FetchOne) @@ -226,6 +303,7 @@ FetchOne def Nothing + True "https" -> return $ BackendSpec @@ -233,25 +311,26 @@ FetchOne def Nothing + True "dir" -> return $ - BackendSpec (FileBackend (pack $ unpack path "*")) FetchAll def Nothing + BackendSpec (FileBackend (pack $ unpack path "*")) FetchAll def Nothing True "glob" -> return $ - BackendSpec (FileBackend path) FetchAll def Nothing + BackendSpec (FileBackend path) FetchAll def Nothing True "file" -> return $ - BackendSpec (FileBackend path) FetchOne def Nothing + BackendSpec (FileBackend path) FetchOne def Nothing True "sql" -> do be <- parseSqlBackendURI path - return $ BackendSpec be FetchAll def Nothing + return $ BackendSpec be FetchAll def Nothing True "post" -> return $ BackendSpec RequestBodyBackend - FetchOne def Nothing + FetchOne def Nothing True "literal" -> return $ BackendSpec (LiteralBackend $ JSON.String path) - FetchOne def Nothing + FetchOne def Nothing True _ -> fail $ "Unknown protocol: " <> show protocol where parseSqlBackendURI path = do @@ -371,6 +450,8 @@ <$> (o .:? "credentials" .!= AnonymousCredentials) <*> (o .:? "method" .!= GET) <*> pure knownContentTypes + parseJSON x = + fail $ "Expected string or array, but found " ++ show x instance Default HttpBackendOptions where def = HttpBackendOptions diff --git a/src/Web/Sprinkles/Bake.hs b/src/Web/Sprinkles/Bake.hs new file mode 100644 --- /dev/null +++ b/src/Web/Sprinkles/Bake.hs @@ -0,0 +1,202 @@ +{-#LANGUAGE NoImplicitPrelude #-} +{-#LANGUAGE OverloadedStrings #-} +{-#LANGUAGE OverloadedLists #-} +{-#LANGUAGE LambdaCase #-} +{-#LANGUAGE ScopedTypeVariables #-} +{-#LANGUAGE FlexibleInstances #-} +{-#LANGUAGE FlexibleContexts #-} +{-#LANGUAGE MultiParamTypeClasses #-} +{-#LANGUAGE TemplateHaskell #-} +{-#LANGUAGE TypeApplications #-} + +module Web.Sprinkles.Bake +where + +import Web.Sprinkles.Prelude +import qualified Data.Text as Text +import Data.Text (Text) +import qualified Data.Set as Set +import Data.Set (Set) +import System.Directory (createDirectoryIfMissing) +import System.FilePath ( (), takeDirectory, replaceExtension ) +import Control.Monad.State +import Control.Lens +import Control.Lens.TH (makeLenses) +import Text.Printf (printf) +import Network.HTTP.Types (Status (..), status200) +import Network.Wai.Test +import Network.Wai (Application, Request (..)) +import qualified Network.Wai as Wai +import Web.Sprinkles.Serve (appFromProject) +import Web.Sprinkles.Project +import qualified Data.ByteString.Lazy as LBS +import qualified Data.ByteString as BS +import Data.Char (ord) +import Text.HTML.TagSoup (parseTags, Tag (..), Attribute) +import qualified Data.CSS.Syntax.Tokens as CSS +import Data.FileEmbed (embedStringFile) + +defHtaccess :: ByteString +defHtaccess = $(embedStringFile "embedded/.htaccess") + +data BakeState + = BakeState + { _bsTodo :: [FilePath] + , _bsDone :: Set FilePath + , _bsBasedir :: FilePath + , _bsApp :: Application + } + +makeLenses ''BakeState + +defBakeState :: BakeState +defBakeState = BakeState [] Set.empty "." defaultApplication + +defaultApplication :: Application +defaultApplication rq respond = + respond $ + Wai.responseLBS + status200 + [("Content-type", "text/plain;charset=utf8")] + "Hello, world!" + +type Bake = StateT BakeState IO + +bakeProject :: FilePath -> Project -> [FilePath] -> IO () +bakeProject destDir project extraEntryPoints = do + putStrLn @Text $ "Baking project into " <> pack destDir + createDirectoryIfMissing True destDir + let app = appFromProject project + runBake destDir entryPoints app $ do + bakeHtaccess + bake404 + bakeApp + where + entryPoints = + [ "/" + , "/sitemap.xml" + , "/favicon.ico" + , "/robots.txt" + ] + ++ extraEntryPoints + +runBake :: FilePath -> [FilePath] -> Application -> Bake a -> IO a +runBake baseDir entryPoints app a = + evalStateT a $ defBakeState + { _bsTodo = entryPoints + , _bsBasedir = baseDir + , _bsApp = app + } + +bakeHtaccess :: Bake () +bakeHtaccess = do + basedir <- use bsBasedir + liftIO $ writeFile (basedir ".htaccess") defHtaccess + +bakeApp :: Bake () +bakeApp = do + use bsTodo >>= \case + (current:rest) -> do + bsTodo .= rest + bakePath current + bsDone %= Set.insert current + bakeApp + _ -> return () + +bakePath :: FilePath -> Bake () +bakePath fp = do + done <- use bsDone + unless (fp `Set.member` done) $ + bakePage CreateIndexHtml [200] fp (dropLeadingSlash fp) + +data HtmlMappingMode = MapHtmlDirect | CreateIndexHtml + +bake404 :: Bake () +bake404 = do + bakePage MapHtmlDirect [404] nonsensicalPath "_errors/404" + where + nonsensicalPath = "/123087408972309872109873012984709218371209847123" + +dropLeadingSlash :: FilePath -> FilePath +dropLeadingSlash = \case + '/':x -> x + x -> x + +bakePage :: HtmlMappingMode -> [Int] -> FilePath -> FilePath -> Bake () +bakePage htmlMode expectedStatuses fp fn = do + app <- use bsApp + basedir <- use bsBasedir + let dstFile = basedir fn + dstDir = takeDirectory dstFile + let session = do + let rq = setPath defaultRequest (fromString fp) + request rq + rp <- liftIO $ runSession session app + let status = simpleStatus rp + liftIO $ printf "GET %s %i %s\n" ("/" fp) (statusCode status) (decodeUtf8 $ statusMessage status) + if statusCode status `elem` expectedStatuses + then do + let ty = fromMaybe "application/octet-stream" $ lookup "content-type" (simpleHeaders rp) + rawTy = BS.takeWhile (/= fromIntegral (ord ';')) ty + rawTySplit = BS.split (fromIntegral . ord $ '/') rawTy + + liftIO $ printf "%s\n" (decodeUtf8 ty) + let (linkUrls, dstDir', dstFile') = case rawTySplit of + ["text", "html"] -> + let body = LBS.toStrict $ simpleBody rp + soup = parseTags (decodeUtf8 body) + linkUrls = map (fp ) . map Text.unpack $ extractLinkedUrls soup + in case htmlMode of + CreateIndexHtml -> + (linkUrls, dstFile, dstFile "index.html") + MapHtmlDirect -> + (linkUrls, dstDir, replaceExtension dstFile "html") + [_, "css"] -> + let body = decodeUtf8 . LBS.toStrict $ simpleBody rp + tokens = either error id $ CSS.tokenize body + linkUrls = map (takeDirectory fp ) . map Text.unpack $ extractCssUrls tokens + in (linkUrls, dstDir, dstFile) + _ -> + ([], dstDir, dstFile) + liftIO $ do + createDirectoryIfMissing True dstDir' + LBS.writeFile dstFile' (simpleBody rp) + bsTodo <>= linkUrls + else do + liftIO $ putStrLn @String "skip" + +extractLinkedUrls :: [Tag Text] -> [Text] +extractLinkedUrls tags = filter isLocalUrl $ do + tags >>= \case + TagOpen "a" attrs -> do + attrs >>= \case + ("href", url) -> return url + _ -> [] + TagOpen "link" attrs -> do + attrs >>= \case + ("href", url) -> return url + _ -> [] + TagOpen "script" attrs -> do + attrs >>= \case + ("src", url) -> return url + _ -> [] + TagOpen "img" attrs -> do + attrs >>= \case + ("src", url) -> return url + _ -> [] + _ -> [] + +isLocalUrl :: Text -> Bool +isLocalUrl url = not + ( ("//" `Text.isPrefixOf` url) + || ("http://" `Text.isPrefixOf` url) + || ("https://" `Text.isPrefixOf` url) + ) + +extractCssUrls :: [CSS.Token] -> [Text] +extractCssUrls tokens = filter isLocalUrl $ go tokens + where + go (CSS.Url url:xs) = url:go xs + go (CSS.Function "url":CSS.String _ url:xs) = url:go xs + go (x:xs) = go xs + go _ = [] diff --git a/src/Web/Sprinkles/Cache.hs b/src/Web/Sprinkles/Cache.hs --- a/src/Web/Sprinkles/Cache.hs +++ b/src/Web/Sprinkles/Cache.hs @@ -6,7 +6,7 @@ module Web.Sprinkles.Cache where -import ClassyPrelude +import Web.Sprinkles.Prelude import Control.MaybeEitherMonad import Data.Time.Clock.POSIX @@ -19,6 +19,9 @@ , cacheDelete :: k -> IO () -- ^ Delete an entry from the cache , cacheVacuum :: IO Int -- ^ Delete all stale keys, return number of keys deleted } + +instance Semigroup (Cache k v) where + (<>) = appendCache instance Monoid (Cache k v) where mempty = nullCache diff --git a/src/Web/Sprinkles/Cache/Filesystem.hs b/src/Web/Sprinkles/Cache/Filesystem.hs --- a/src/Web/Sprinkles/Cache/Filesystem.hs +++ b/src/Web/Sprinkles/Cache/Filesystem.hs @@ -4,11 +4,12 @@ module Web.Sprinkles.Cache.Filesystem where -import ClassyPrelude +import Web.Sprinkles.Prelude import Data.Char (isAlphaNum, ord, isDigit, isAlpha, chr) import Prelude (read) import Web.Sprinkles.Cache import System.IO (IOMode (..), withFile) +import System.IO.Error (catchIOError) import System.Directory (removeFile, getDirectoryContents) import System.FilePath (takeFileName) import System.PosixCompat.Files (getFileStatus, modificationTime) @@ -25,26 +26,25 @@ 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 = +filesystemCache serializeKey writeValue readValue cacheDir maxAge = Cache { cacheGet = \key -> do let filename = keyToFilename key catchIOError (do status <- getFileStatus filename - body <- withFile filename ReadMode readValue + body <- System.IO.withFile filename ReadMode readValue return $ Just body ) (ignoreNonexisting Nothing) , cachePut = \key val -> do let filename = keyToFilename key - withFile filename WriteMode (\h -> writeValue h val) + System.IO.withFile filename WriteMode (\h -> writeValue h val) , cacheDelete = \key -> do let filename = keyToFilename key removeFile filename `catchIOError` ignoreNonexisting_ @@ -64,7 +64,6 @@ } where keyToFilename key = cacheDir encodeFilename (serializeKey key) <> ".cache" - keyFromFilename = deserializeKey . decodeFilename . takeFileName encodeFilename :: String -> FilePath encodeFilename = diff --git a/src/Web/Sprinkles/Cache/Memcached.hs b/src/Web/Sprinkles/Cache/Memcached.hs --- a/src/Web/Sprinkles/Cache/Memcached.hs +++ b/src/Web/Sprinkles/Cache/Memcached.hs @@ -1,31 +1,38 @@ {-#LANGUAGE NoImplicitPrelude #-} +{-#LANGUAGE LambdaCase #-} {-#LANGUAGE ScopedTypeVariables #-} {-#LANGUAGE OverloadedStrings #-} module Web.Sprinkles.Cache.Memcached where -import ClassyPrelude +import Web.Sprinkles.Prelude 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 +import qualified Database.Memcache.Client as Memcache memcachedCache :: IO (Cache ByteString ByteString) memcachedCache = do - let connectInfo :: Memcached.ConnectInfo = def - withConnection = Memcached.withConnection connectInfo + let options :: Memcache.Options = def + withConnection = + bracket + (Memcache.newClient [] options) + (Memcache.quit) expiry = 60 return Cache { cacheGet = \key -> do - lazyVal <- withConnection $ Memcached.get_ key - return $ toStrict <$> lazyVal + withConnection $ \client -> Memcache.gat client key expiry >>= \case + Just (val, _, _) -> return (Just val) + Nothing -> return Nothing , cachePut = \key val -> do - withConnection $ Memcached.set 0 expiry key (fromStrict val) + withConnection $ \client -> + Memcache.set client key val 0 expiry return () , cacheDelete = \key -> do - withConnection $ Memcached.delete key + withConnection $ \client -> + Memcache.delete client key 0 return () , cacheVacuum = return 0 } diff --git a/src/Web/Sprinkles/Cache/Memory.hs b/src/Web/Sprinkles/Cache/Memory.hs --- a/src/Web/Sprinkles/Cache/Memory.hs +++ b/src/Web/Sprinkles/Cache/Memory.hs @@ -3,7 +3,7 @@ module Web.Sprinkles.Cache.Memory where -import ClassyPrelude +import Web.Sprinkles.Prelude import Web.Sprinkles.Cache import Data.Time.Clock.POSIX import qualified Data.HashMap.Strict as HashMap diff --git a/src/Web/Sprinkles/Databases.hs b/src/Web/Sprinkles/Databases.hs --- a/src/Web/Sprinkles/Databases.hs +++ b/src/Web/Sprinkles/Databases.hs @@ -10,7 +10,7 @@ module Web.Sprinkles.Databases where -import ClassyPrelude +import Web.Sprinkles.Prelude import Data.Aeson as JSON import Data.Aeson.TH as JSON import qualified Database.HDBC as HDBC @@ -19,15 +19,33 @@ import Database.HDBC.MySQL (connectMySQL, MySQLConnectInfo (..)) import qualified Data.Serialize as Cereal import Data.Serialize (Serialize) +import Data.Expandable data DSN = DSN { dsnDriver :: SqlDriver, dsnDetails :: Text } deriving (Show, Generic) -type instance Element DSN = Text +data ResultSetMode + = ResultsMerge + | ResultsNth Int + | ResultsLast + deriving (Show, Generic) -instance MonoFunctor DSN where - omap f (DSN driver details) = DSN driver (f details) +instance FromJSON ResultSetMode where + parseJSON = \case + String "merge" -> return ResultsMerge + String "first" -> return $ ResultsNth 0 + String "last" -> return ResultsLast + String x -> fail $ "Invalid result set mode " ++ show x + Number i -> if i >= 0 + then return (ResultsNth . round $ i) + else fail $ "Invalid result set index " ++ show i + x -> fail $ "Expected integer or string for result set mode, got " ++ show x +instance Serialize ResultSetMode where + +instance ExpandableM Text DSN where + expandM f (DSN driver details) = DSN driver <$> f details + data SqlDriver = SqliteDriver | PostgreSQLDriver | MySQLDriver @@ -72,8 +90,8 @@ instance Serialize DSN where put (DSN driver details) = do Cereal.put driver - Cereal.put (unpack details) - get = DSN <$> Cereal.get <*> (pack <$> Cereal.get) + Cereal.put ((unpack :: Text -> String) details) + get = DSN <$> Cereal.get <*> ((pack :: String -> Text) <$> Cereal.get) dsnToText :: DSN -> Text dsnToText (DSN driver details) = sqlDriverID driver <> ":" <> details @@ -89,7 +107,7 @@ withConnection dsn inner = do conn <- connect dsn inner conn - + connect :: DSN -> IO HDBC.ConnWrapper connect (DSN driver details) = case driver of diff --git a/src/Web/Sprinkles/Exceptions.hs b/src/Web/Sprinkles/Exceptions.hs --- a/src/Web/Sprinkles/Exceptions.hs +++ b/src/Web/Sprinkles/Exceptions.hs @@ -13,7 +13,7 @@ ) where -import ClassyPrelude +import Web.Sprinkles.Prelude import Control.Exception import qualified Database.HDBC as HDBC import Database.HDBC (SqlError (..)) @@ -44,7 +44,7 @@ throwInvalidReaderException :: String -> String -> IO () throwInvalidReaderException name msg = - throwM $ InvalidReaderException (pack name) (pack msg) + Control.Exception.throwIO $ InvalidReaderException (pack name) (pack msg) data TemplateNotFoundException = TemplateNotFoundException Text deriving (Show, Eq, Generic) @@ -65,8 +65,15 @@ WithSourceContext source (withoutSourceContext e) instance HasSourceContext Ginger.ParserError where - overrideSourceContext = \s e -> e { peSourceName = Just . unpack $ s } + overrideSourceContext = setGingerSourceName +setGingerSourceName :: Text -> Ginger.ParserError -> Ginger.ParserError +setGingerSourceName source e@(Ginger.ParserError { peSourcePosition = Just pos }) = + e { peSourcePosition = + Just (Ginger.setSourceName pos (unpack source)) + } +setGingerSourceName source e = e + withSourceContext :: Exception e => Text -> e -> SomeException withSourceContext context = toException . WithSourceContext context . toException @@ -102,8 +109,8 @@ formatGingerParserError :: Ginger.ParserError -> Text formatGingerParserError e = - "line " <> (fromMaybe "?" . fmap tshow . Ginger.peSourceLine $ e) - <> ", column " <> (fromMaybe "?" . fmap tshow . Ginger.peSourceColumn $ e) + "line " <> (fromMaybe "?" . fmap (tshow . Ginger.sourceLine) . Ginger.peSourcePosition $ e) + <> ", column " <> (fromMaybe "?" . fmap (tshow . Ginger.sourceColumn) . Ginger.peSourcePosition $ e) <> ": " <> pack (Ginger.peErrorMessage e) formatYamlParseException :: YAML.ParseException -> Text diff --git a/src/Web/Sprinkles/Handlers.hs b/src/Web/Sprinkles/Handlers.hs --- a/src/Web/Sprinkles/Handlers.hs +++ b/src/Web/Sprinkles/Handlers.hs @@ -12,7 +12,7 @@ ) where -import ClassyPrelude +import Web.Sprinkles.Prelude import Web.Sprinkles.Handlers.Common import Web.Sprinkles.Handlers.Static import Web.Sprinkles.Handlers.Redirect diff --git a/src/Web/Sprinkles/Handlers/Common.hs b/src/Web/Sprinkles/Handlers/Common.hs --- a/src/Web/Sprinkles/Handlers/Common.hs +++ b/src/Web/Sprinkles/Handlers/Common.hs @@ -6,10 +6,11 @@ {-#LANGUAGE FlexibleInstances #-} {-#LANGUAGE FlexibleContexts #-} {-#LANGUAGE MultiParamTypeClasses #-} +{-#LANGUAGE DeriveGeneric #-} module Web.Sprinkles.Handlers.Common where -import ClassyPrelude +import Web.Sprinkles.Prelude import Web.Sprinkles.Exceptions import Web.Sprinkles.Backends import qualified Network.Wai as Wai @@ -19,28 +20,49 @@ import Network.HTTP.Types (Status, status200, status302, status400, status404, status405, status500) import Web.Sprinkles.Handlers.Respond -import Text.Ginger.Html (Html, htmlSource) +import Text.Ginger.Html (Html, htmlSource, unsafeRawHtml) +import qualified Text.Ginger as Ginger import Web.Sprinkles.Backends.Loader.Type - (PostBodySource (..), pbsFromRequest, pbsInvalid) + (RequestContext (..), pbsFromRequest, pbsInvalid) +import Web.Sprinkles.Backends.Data + (BackendData (..), BackendSource (..), Verification (..)) import Web.Sprinkles.Rule (expandReplacementBackend) import Data.AList (AList) import qualified Data.AList as AList -import Text.Ginger (GVal, ToGVal (..), Run, marshalGVal) +import Text.Ginger (GVal, ToGVal (..), Run, marshalGValEx, hoistRun, SourcePos) +import Text.Ginger.Run.VM (withEncoder) import Control.Monad.Writer (Writer) +import Web.Sprinkles.SessionHandle +import Web.Sprinkles.Exceptions +import qualified Data.Foldable as Foldable +import qualified Data.Aeson as JSON +import Data.Aeson (FromJSON (..)) +import Text.Printf (printf) data NotFoundException = NotFoundException - deriving (Show) + deriving (Show, Eq, Generic) instance Exception NotFoundException where data MethodNotAllowedException = MethodNotAllowedException - deriving (Show) + deriving (Show, Eq, Generic) instance Exception MethodNotAllowedException where +data NotAllowedException = NotAllowedException + deriving (Show, Eq, Generic) + +instance Exception NotAllowedException where + +data RequestValidationException = RequestValidationException + deriving (Show, Eq, Generic) + +instance Exception RequestValidationException + type ContextualHandler = - HashMap Text (Items (BackendData IO Html)) -> + HashMap Text (Items (BackendData SourcePos IO Html)) -> Project -> + Maybe SessionHandle -> Wai.Application handleNotFound :: Project -> Wai.Request -> (Wai.Response -> IO Wai.ResponseReceived) -> NotFoundException -> IO Wai.ResponseReceived @@ -57,6 +79,20 @@ request respond +handleNotAllowed :: Project -> Wai.Request -> (Wai.Response -> IO Wai.ResponseReceived) -> NotAllowedException -> IO Wai.ResponseReceived +handleNotAllowed project request respond _ = do + respond $ Wai.responseLBS + status400 + [("Content-type", "text/plain")] + "Not allowed" + +handleRequestValidation :: Project -> Wai.Request -> (Wai.Response -> IO Wai.ResponseReceived) -> RequestValidationException -> IO Wai.ResponseReceived +handleRequestValidation project request respond _ = do + respond $ Wai.responseLBS + status400 + [("Content-type", "text/plain")] + "Invalid Request" + handleHttpError :: Status -> Text -> Text @@ -71,13 +107,14 @@ respondNormally = do backendData <- loadBackendDict (writeLog logger) - (pbsFromRequest request) + (pbsFromRequest request Nothing) cache backendPaths (setFromList []) (mapFromList []) respondTemplateHtml project + Nothing status templateName backendData @@ -106,37 +143,91 @@ message = "Something went pear-shaped. The problem seems to be on our side." loadBackendDict :: (LogLevel -> Text -> IO ()) - -> PostBodySource + -> RequestContext -> 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 + -> HashMap Text (GVal (Run SourcePos IO Text)) + -> IO (HashMap Text (Items (BackendData SourcePos IO Html))) +loadBackendDict writeLog reqCtx cache backendPaths required globalContext = do mapFromList <$> go globalContext (AList.toList backendPaths) where - go :: HashMap Text (GVal (Run (Writer Text) Text)) + go :: HashMap Text (GVal (Run SourcePos IO Text)) -> [(Text, BackendSpec)] - -> IO [(Text, Items (BackendData IO Html))] - go _ [] = return [] + -> IO [(Text, Items (BackendData SourcePos IO Html))] go context ((key, backendSpec):specs) = do - let expBackendSpec = (expandReplacementBackend context backendSpec) - bd :: Items (BackendData IO Html) + expBackendSpec <- expandReplacementBackend context backendSpec + bd :: Items (BackendData SourcePos IO Html) <- loadBackendData writeLog - postBodySrc + reqCtx cache expBackendSpec + Foldable.traverse_ (verifyBD writeLog reqCtx) bd 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) + let bdG :: GVal (Run SourcePos IO Html) bdG = toGVal bd - bdGP :: GVal (Run (Writer Text) Text) - bdGP = marshalGVal bdG + bdGP :: GVal (Run SourcePos IO Text) + bdGP = marshalGValHtmlToText bdG context' = insertMap key bdGP context remainder <- go context' specs return $ resultItem:remainder + go _ _ = return [] + +verifyBD :: (LogLevel -> Text -> IO ()) -> RequestContext -> BackendData SourcePos IO Html -> IO () +verifyBD writeLog reqCtx bd = + case bdVerification bd of + Trusted -> do + writeLog Debug "Trusted" + return () + VerifyCSRF -> do + writeLog Debug "CSRF" + let csrfHeaderMay = decodeUtf8 <$> lookupHeader reqCtx "X-Form-Token" + csrfFormFieldMay = + (fromJSONMay (bdJSON bd) :: Maybe (HashMap Text JSON.Value)) + >>= lookup "__form_token" + >>= fromJSONMay + writeLog Debug $ "POST (JSON): " <> tshow (bdJSON bd) + case sessionHandle reqCtx of + Nothing -> do + -- No session means there's no need to check the + -- CSRF token, because without a session, the user + -- cannot be holding an authenticated identity. + writeLog Notice "No session, not performing CSRF validation" + return () + Just session -> do + writeLog Notice "Session found, checking CSRF token" + csrfToken <- maybe + (throwM RequestValidationException) + return + =<< sessionGet session "csrf" + let candidates :: [Text] + candidates = catMaybes [csrfHeaderMay, csrfFormFieldMay] + writeLog Notice . pack $ printf "CSRF token: %s; candidates: %s" + (show csrfToken) (show candidates) + when (null candidates) + (throwM RequestValidationException) + when (any (/= csrfToken) candidates) + (throwM RequestValidationException) + +fromJSONMay :: FromJSON a => JSON.Value -> Maybe a +fromJSONMay x = case JSON.fromJSON x of + JSON.Error _ -> Nothing + JSON.Success a -> Just a + +marshalGValHtmlToText :: GVal (Run SourcePos IO Html) -> GVal (Run SourcePos IO Text) +marshalGValHtmlToText = marshalGValEx hoistRunToText hoistRunFromText + +hoistRunToText :: Run SourcePos IO Html a -> Run SourcePos IO Text a +hoistRunToText = + hoistRun htmlSource unsafeRawHtml + . withEncoder (unsafeRawHtml . Ginger.asText) +hoistRunFromText:: Run SourcePos IO Text a -> Run SourcePos IO Html a +hoistRunFromText = + hoistRun unsafeRawHtml htmlSource + diff --git a/src/Web/Sprinkles/Handlers/JSON.hs b/src/Web/Sprinkles/Handlers/JSON.hs --- a/src/Web/Sprinkles/Handlers/JSON.hs +++ b/src/Web/Sprinkles/Handlers/JSON.hs @@ -11,7 +11,7 @@ ) where -import ClassyPrelude +import Web.Sprinkles.Prelude import Web.Sprinkles.Backends import qualified Network.Wai as Wai import Web.Sprinkles.Logger as Logger @@ -21,7 +21,7 @@ import Network.HTTP.Types (Status, status200, status302, status400, status404, status500) import Web.Sprinkles.Backends.Loader.Type - (PostBodySource (..), pbsFromRequest, pbsInvalid) + (RequestContext (..), pbsFromRequest, pbsInvalid) import Data.Aeson as JSON import Data.Aeson.Encode.Pretty as JSON import Data.Aeson.TH as JSON @@ -31,6 +31,7 @@ handleJSONTarget :: ContextualHandler handleJSONTarget backendData project + session request respond = do respond $ Wai.responseLBS diff --git a/src/Web/Sprinkles/Handlers/Redirect.hs b/src/Web/Sprinkles/Handlers/Redirect.hs --- a/src/Web/Sprinkles/Handlers/Redirect.hs +++ b/src/Web/Sprinkles/Handlers/Redirect.hs @@ -11,7 +11,7 @@ ) where -import ClassyPrelude +import Web.Sprinkles.Prelude import Web.Sprinkles.Backends import qualified Network.Wai as Wai import Web.Sprinkles.Logger as Logger @@ -21,7 +21,7 @@ import Network.HTTP.Types (Status, status200, status302, status400, status404, status500) import Web.Sprinkles.Backends.Loader.Type - (PostBodySource (..), pbsFromRequest, pbsInvalid) + (RequestContext (..), pbsFromRequest, pbsInvalid) import qualified Data.ByteString.Lazy.UTF8 as LUTF8 import qualified Data.ByteString.UTF8 as UTF8 import Data.AList (AList) @@ -30,6 +30,7 @@ handleRedirectTarget redirectPath backendData project + session request respond = respond $ Wai.responseLBS diff --git a/src/Web/Sprinkles/Handlers/Respond.hs b/src/Web/Sprinkles/Handlers/Respond.hs --- a/src/Web/Sprinkles/Handlers/Respond.hs +++ b/src/Web/Sprinkles/Handlers/Respond.hs @@ -7,19 +7,23 @@ {-#LANGUAGE FlexibleInstances #-} {-#LANGUAGE FlexibleContexts #-} {-#LANGUAGE MultiParamTypeClasses #-} +{-#LANGUAGE TypeApplications #-} + module Web.Sprinkles.Handlers.Respond ( respondTemplateHtml , respondTemplateText ) where -import ClassyPrelude +import Web.Sprinkles.Prelude hiding (Builder) 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 Web.Sprinkles.TemplateContext +import Web.Sprinkles.SessionHandle import Text.Ginger (parseGinger, Template, runGingerT, GingerContext, GVal(..), ToGVal(..), @@ -29,7 +33,7 @@ import qualified Data.ByteString.UTF8 as UTF8 import qualified Data.ByteString.Lazy.UTF8 as LUTF8 -import Data.ByteString.Builder (stringUtf8) +import Data.ByteString.Builder (stringUtf8, Builder) import qualified Data.Yaml as YAML import qualified Data.Aeson as JSON import qualified Data.Aeson.Encode.Pretty as JSON @@ -46,7 +50,7 @@ import Network.HTTP.Types.URI (queryToQueryText) import Web.Sprinkles.Backends.Loader.Type - (PostBodySource (..), pbsFromRequest, pbsInvalid) + (RequestContext (..), pbsFromRequest, pbsInvalid) instance ToGVal m ByteString where toGVal = toGVal . UTF8.toString @@ -54,193 +58,87 @@ 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 +respondTemplateHtml :: ToGVal (Ginger.Run Ginger.SourcePos IO Html) a => Project + -> Maybe SessionHandle -> 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 +respondTemplateHtml = + respondTemplate + contentType + writeText + makeContext + where + contentType = "text/html;charset=utf8" + writeText write = write . stringUtf8 . unpack . htmlSource + makeContext = Ginger.makeContextHtmlM -respondTemplateText :: ToGVal (Ginger.Run IO Text) a +respondTemplateText :: ToGVal (Ginger.Run Ginger.SourcePos IO Text) a => Project + -> Maybe SessionHandle -> 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 +respondTemplateText = + respondTemplate + contentType + writeText + makeContext + where + contentType = "text/plain;charset=utf8" + writeText write = write . stringUtf8 . unpack @Text + makeContext = Ginger.makeContextTextM + +respondTemplate :: ToGVal (Ginger.Run Ginger.SourcePos IO h) a + => ToGVal (Ginger.Run Ginger.SourcePos IO h) h + => Monoid h + => ByteString -- ^ content type + -> ( (Builder -> IO ()) + -> h -> IO () + ) + -> ( (Text -> Ginger.Run Ginger.SourcePos IO h (GVal (Ginger.Run Ginger.SourcePos IO h))) + -> (h -> IO ()) + -> GingerContext Ginger.SourcePos IO h + ) + -> Project + -> Maybe SessionHandle + -> Status + -> Text + -> HashMap Text a + -> Wai.Application +respondTemplate contentType + writeText + makeContext + project + session + status + templateName + contextMap + request + respond = do + let contextLookup = mkContextLookup request project session 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 + let context = makeContext contextLookup (writeText write) runGingerT context template flush -mkContextLookup :: (ToGVal (Ginger.Run IO h) a) +mkContextLookup :: (ToGVal (Ginger.Run Ginger.SourcePos IO h) a) => Wai.Request -> Project + -> Maybe SessionHandle -> HashMap Text a -> Text - -> Ginger.Run IO h (GVal (Ginger.Run IO h)) -mkContextLookup request project contextMap key = do + -> Ginger.Run Ginger.SourcePos IO h (GVal (Ginger.Run Ginger.SourcePos IO h)) +mkContextLookup request project session 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))) - ] + sprinklesContext <- liftIO $ + sprinklesGingerContext cache request session logger + let contextMap' = + fmap toGVal contextMap <> sprinklesContext 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 --- a/src/Web/Sprinkles/Handlers/Static.hs +++ b/src/Web/Sprinkles/Handlers/Static.hs @@ -10,7 +10,7 @@ ) where -import ClassyPrelude +import Web.Sprinkles.Prelude import Web.Sprinkles.Backends import qualified Network.Wai as Wai import Web.Sprinkles.Logger as Logger @@ -20,7 +20,7 @@ import Network.HTTP.Types (Status, status200, status206, status302, status400, status404, status500) import Web.Sprinkles.Backends.Loader.Type - (PostBodySource (..), pbsFromRequest, pbsInvalid) + (RequestContext (..), pbsFromRequest, pbsInvalid) import Web.Sprinkles.Backends.Data (RawBytes (..)) import Data.AList (AList) @@ -34,6 +34,7 @@ handleStaticTarget childPathMay backendData project + session request respond = do backendItemBase <- case lookup "file" backendData of diff --git a/src/Web/Sprinkles/Handlers/Template.hs b/src/Web/Sprinkles/Handlers/Template.hs --- a/src/Web/Sprinkles/Handlers/Template.hs +++ b/src/Web/Sprinkles/Handlers/Template.hs @@ -11,7 +11,7 @@ ) where -import ClassyPrelude +import Web.Sprinkles.Prelude import Web.Sprinkles.Backends import qualified Network.Wai as Wai import Web.Sprinkles.Logger as Logger @@ -22,18 +22,21 @@ import Network.HTTP.Types (Status, status200, status302, status400, status404, status500) import Web.Sprinkles.Backends.Loader.Type - (PostBodySource (..), pbsFromRequest, pbsInvalid) + (RequestContext (..), pbsFromRequest, pbsInvalid) import Data.AList (AList) import qualified Data.AList as AList +import Web.Sprinkles.SessionHandle handleTemplateTarget :: Text -> ContextualHandler handleTemplateTarget templateName backendData project + session request respond = respondTemplateHtml project + session status200 templateName backendData diff --git a/src/Web/Sprinkles/Logger.hs b/src/Web/Sprinkles/Logger.hs --- a/src/Web/Sprinkles/Logger.hs +++ b/src/Web/Sprinkles/Logger.hs @@ -14,11 +14,12 @@ ) where -import ClassyPrelude +import Web.Sprinkles.Prelude import Control.Concurrent (forkIO) -import Data.Aeson (FromJSON (..), Value (..), (.:)) +import Data.Aeson (FromJSON (..), Value (..), (.:), withObject) import qualified System.Posix.Syslog as Syslog import Data.Default (Default (..)) +import Foreign.C.String (withCStringLen) data LogLevel = Debug | Notice @@ -51,7 +52,7 @@ deriving (Show, Eq) instance FromJSON LogMessage where - parseJSON (Object o) = + parseJSON = withObject "LogMessage" $ \o -> do LogMessage <$> o .: "timestamp" <*> o .: "level" <*> o .: "message" @@ -103,11 +104,13 @@ Syslog.withSyslog "sprinkles" [] - Syslog.USER - (Syslog.logUpTo $ logLevelToSyslogPrio level) $ + Syslog.User $ do + let minPrio = logLevelToSyslogPrio level + Syslog.setlogmask [minPrio..maxBound] + withCStringLen (unpack . lmMessage $ msg) $ Syslog.syslog - (logLevelToSyslogPrio . lmLevel $ msg) - (unpack . lmMessage $ msg) + Nothing + (logLevelToSyslogPrio . lmLevel $ msg) -- | A logger that wraps another logger and adds line buffering. newBufferedLogger :: Logger -> IO Logger diff --git a/src/Web/Sprinkles/MatchedText.hs b/src/Web/Sprinkles/MatchedText.hs --- a/src/Web/Sprinkles/MatchedText.hs +++ b/src/Web/Sprinkles/MatchedText.hs @@ -7,7 +7,7 @@ module Web.Sprinkles.MatchedText where -import ClassyPrelude +import Web.Sprinkles.Prelude import qualified Text.Ginger as Ginger import Text.Ginger diff --git a/src/Web/Sprinkles/Pandoc.hs b/src/Web/Sprinkles/Pandoc.hs new file mode 100644 --- /dev/null +++ b/src/Web/Sprinkles/Pandoc.hs @@ -0,0 +1,15 @@ +module Web.Sprinkles.Pandoc +where + +import Text.Pandoc + +pandocReaderOptions :: ReaderOptions +pandocReaderOptions = def + { readerStandalone = + True + , readerExtensions = + disableExtension Ext_raw_html + . disableExtension Ext_raw_attribute + . disableExtension Ext_raw_tex + $ pandocExtensions + } diff --git a/src/Web/Sprinkles/PandocGVal.hs b/src/Web/Sprinkles/PandocGVal.hs --- a/src/Web/Sprinkles/PandocGVal.hs +++ b/src/Web/Sprinkles/PandocGVal.hs @@ -7,10 +7,11 @@ module Web.Sprinkles.PandocGVal where -import ClassyPrelude hiding (asText, asList) +import Web.Sprinkles.Prelude 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.Html as Ginger import qualified Text.Ginger.Run.VM as Ginger import Text.Pandoc import Text.Pandoc.Walk (query, walk) @@ -19,12 +20,9 @@ import Data.Scientific (fromFloatDigits) writerOptions :: WriterOptions -writerOptions = - def { writerStandalone = False - , writerHtml5 = True - } +writerOptions = def -gfnWithMediaRoot :: Monad m => Pandoc -> Ginger.Function (Ginger.Run m h) +gfnWithMediaRoot :: Monad m => Pandoc -> Ginger.Function (Ginger.Run p m h) gfnWithMediaRoot pandoc args = do defMediaroot <- fromMaybe def . Ginger.lookupKey "path" <$> Ginger.getVar "request" let extracted = @@ -38,7 +36,7 @@ return $ toGVal pandoc' _ -> return def -gfnWithAppRoot :: Monad m => Pandoc -> Ginger.Function (Ginger.Run m h) +gfnWithAppRoot :: Monad m => Pandoc -> Ginger.Function (Ginger.Run p m h) gfnWithAppRoot pandoc args = do defApproot <- Ginger.getVar "approot" let extracted = @@ -84,7 +82,7 @@ relativeUrlPrefix :: String -> Pandoc -> Pandoc relativeUrlPrefix prefix = modifyUrls (prefixRelativeUrl prefix) -instance Monad m => ToGVal (Ginger.Run m h) Pandoc where +instance Monad m => ToGVal (Ginger.Run p m h) Pandoc where toGVal pandoc@(Pandoc meta blocks) = def { asList = Just $ map toGVal blocks , asDictItems = @@ -104,12 +102,12 @@ "withMediaRoot" -> Just . Ginger.fromFunction . gfnWithMediaRoot $ pandoc "withAppRoot" -> Just . Ginger.fromFunction . gfnWithAppRoot $ pandoc _ -> Nothing - , asHtml = unsafeRawHtml . pack . writeHtmlString writerOptions $ pandoc + , asHtml = pandocToHtml pandoc , asText = unwords . fmap (asText . toGVal) $ blocks , asBoolean = True , asNumber = Nothing , asFunction = Nothing - , Ginger.length = Just (ClassyPrelude.length blocks) + , Ginger.length = Just (Web.Sprinkles.Prelude.length blocks) , isNull = False } @@ -138,12 +136,12 @@ in def { asList = Just listItems , asDictItems = Just $ mapToList props , asLookup = Just $ \key -> lookup key props - , asHtml = unsafeRawHtml . pack . writeHtmlString writerOptions $ pandoc + , asHtml = pandocToHtml pandoc , asText = unwords . fmap ((<> " ") . asText) $ listItems , asBoolean = True , asNumber = Nothing , asFunction = Nothing - , Ginger.length = Just (ClassyPrelude.length listItems) + , Ginger.length = Just (Web.Sprinkles.Prelude.length listItems) , isNull = False } @@ -195,6 +193,13 @@ ] , fmap toGVal items ) +blockChildren (LineBlock items) = + ( mapFromList + [ "type" ~> ("lines" :: Text) + , "items" ~> items + ] + , fmap toGVal items + ) blockChildren (DefinitionList pairs) = ( mapFromList [ "type" ~> ("dl" :: Text) @@ -252,6 +257,12 @@ toGVal AlignCenter = toGVal ("center" :: Text) toGVal AlignDefault = def +pandocToHtml :: Pandoc -> Ginger.Html +pandocToHtml pandoc = + case runPure $ writeHtml5String writerOptions pandoc of + Left err -> unsafeRawHtml "" + Right html -> unsafeRawHtml html + instance ToGVal m Inline where toGVal inline = let pandoc = Pandoc nullMeta [Plain [inline]] @@ -263,12 +274,12 @@ in def { asList = Just listItems , asDictItems = Just $ mapToList props , asLookup = Just $ \key -> lookup key props - , asHtml = unsafeRawHtml . pack . writeHtmlString writerOptions $ pandoc + , asHtml = pandocToHtml pandoc , asText = unwords . fmap asText $ listItems , asBoolean = True , asNumber = Nothing , asFunction = Nothing - , Ginger.length = Just (ClassyPrelude.length listItems) + , Ginger.length = Just (Web.Sprinkles.Prelude.length listItems) , isNull = False } diff --git a/src/Web/Sprinkles/Pattern.hs b/src/Web/Sprinkles/Pattern.hs --- a/src/Web/Sprinkles/Pattern.hs +++ b/src/Web/Sprinkles/Pattern.hs @@ -8,7 +8,7 @@ module Web.Sprinkles.Pattern where -import ClassyPrelude hiding ( (<|>) ) +import Web.Sprinkles.Prelude hiding ( (<|>), Any, option ) import Text.Parsec as Parsec import qualified Data.Text as Text import Data.Aeson as JSON @@ -128,7 +128,7 @@ return $ Regex body options regexCharP :: Parsec Text () Char -regexCharP = (char '\\' >> char '/') <|> noneOf "/" +regexCharP = (Parsec.try $ char '\\' >> char '/') <|> noneOf "/" regexOptionP :: Parsec Text () RE.CompOption regexOptionP = (char 'm' >> return RE.compMultiline) diff --git a/src/Web/Sprinkles/Prelude.hs b/src/Web/Sprinkles/Prelude.hs new file mode 100644 --- /dev/null +++ b/src/Web/Sprinkles/Prelude.hs @@ -0,0 +1,486 @@ +{-#LANGUAGE MultiParamTypeClasses #-} +{-#LANGUAGE FlexibleInstances #-} +{-#LANGUAGE FlexibleContexts #-} +{-#LANGUAGE RankNTypes #-} +{-#LANGUAGE FunctionalDependencies #-} +{-#LANGUAGE OverloadedStrings #-} +module Web.Sprinkles.Prelude +( module P +, LText +, LByteString +, Packable (..) +, MapLike (..) +, SetLike (..) +, TextLike (..) +, ListLike (..) +, StrictnessConvert (..) +, Encode (..) +, splitElem +, readMay +, Cased (..) +, throwM +, FileIO (..) +, hPut +, (++) +, concat +, empty +, getArgs +, getEnv +, lookupEnv +, sha1, sha256, sha512 +) +where + +import Prelude as P hiding ( unwords + , words + , lookup + , length + , take + , drop + , takeWhile + , dropWhile + , null + , tail + , break + , filter + , unlines + , putStr + , putStrLn + , hPutStr + , hPutStrLn + , readFile + , writeFile + , getContents + , hGetContents + , (++) + , concat + , empty + , sha1 + ) + +import Data.Text as P (Text) +import Data.ByteString as P (ByteString) +import Data.Hashable (Hashable) +import Data.Map as P (Map) +import Data.HashMap.Strict as P (HashMap) +import Data.Set as P (Set) +import Data.HashSet as P (HashSet) +import Data.Hashable as P (Hashable (..)) +import Data.Maybe as P (fromMaybe, catMaybes, isNothing, isJust) +import Data.String as P (IsString (..)) +import Data.Vector as P (Vector) +import Data.List as P (sortOn) +import Data.Word as P (Word8, Word16, Word32, Word64, Word) +import Data.Int as P (Int8, Int16, Int32, Int64) +import Control.Monad as P +import Data.Semigroup as P hiding (getAll, All) +import Data.Monoid as P hiding (getFirst, getLast, First, Last, getAll, All) +import Control.Monad.IO.Class as P +import Control.Exception as P (bracket, bracket_, throw, catch) +import Control.Applicative as P hiding (empty) +import Data.IORef as P +import Control.Concurrent as P +import Control.Concurrent.STM as P +import Control.Concurrent.Chan as P +import Control.Concurrent.MVar as P +import Control.Exception as P hiding (throw) +import Data.Time as P (UTCTime (..), getCurrentTime) +import GHC.Generics as P (Generic) +import System.IO as P (stdin, stdout, stderr, Handle) +import System.IO.Error as P +import System.FilePath as P +import Text.Printf as P (printf) +import Control.Monad.Identity as P + +import qualified Prelude +import qualified Data.List as List +import qualified Data.List.Split as List (splitWhen, splitOn) +import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified Data.HashMap.Strict as HashMap +import qualified Data.HashSet as HashSet +import qualified Data.Text.Lazy as LText +import qualified Data.Text.Lazy.IO as LText +import qualified Data.Text.Lazy.Encoding as LText +import qualified Data.Text as Text +import qualified Data.Text.IO as Text +import qualified Data.Text.Encoding as Text +import qualified Data.Char as Char (toLower, toUpper) +import qualified Data.ByteString.Lazy as LBS +import qualified Data.ByteString as BS +import qualified Data.Vector as Vector +import qualified System.IO +import qualified System.Environment as Env +import qualified Data.Digest.Pure.SHA as SHA +import Text.Read (readMaybe) +import Control.Exception (throw) + +readMay :: (Read a, Packable t [Char]) => t -> Maybe a +readMay = readMaybe . unpack + +throwM :: (Exception e, Monad m) => e -> m a +throwM = throw + +type LText = LText.Text + +type LByteString = LBS.ByteString + +(++) :: Semigroup m => m -> m -> m +(++) = (<>) + +concat :: Monoid m => [m] -> m +concat = mconcat + +empty :: Monoid m => m +empty = mempty + +class Packable t s | t -> s where + pack :: s -> t + unpack :: t -> s + +instance Packable Text [Char] where + pack = Text.pack + unpack = Text.unpack + +instance Packable LText [Char] where + pack = LText.pack + unpack = LText.unpack + +instance Packable [a] [a] where + pack = id + unpack = id + + +class MapLike m k v | m -> k, m -> v where + mapFromList :: [(k,v)] -> m + mapToList :: m -> [(k,v)] + lookup :: k -> m -> Maybe v + insertMap :: k -> v -> m -> m + deleteMap :: k -> m -> m + keys :: m -> [k] + +instance (Eq k, Hashable k) => MapLike (HashMap k v) k v where + mapFromList = HashMap.fromList + mapToList = HashMap.toList + lookup = HashMap.lookup + insertMap = HashMap.insert + deleteMap = HashMap.delete + keys = HashMap.keys + +instance (Ord k) => MapLike (Map k v) k v where + mapFromList = Map.fromList + mapToList = Map.toList + lookup = Map.lookup + insertMap = Map.insert + deleteMap = Map.delete + keys = Map.keys + +instance (Ord k, Eq k) => MapLike [(k, v)] k v where + mapFromList = id + mapToList = id + lookup = List.lookup + insertMap = \k v -> ((k,v):) + deleteMap = \k -> List.filter ((/= k) . fst) + keys = map fst + +class SetLike l c | l -> c where + setFromList :: [c] -> l + +instance Ord a => SetLike (Set a) a where + setFromList = Set.fromList + +class ListLike l c | l -> c where + length :: l -> Int + take :: Int -> l -> l + drop :: Int -> l -> l + takeWhile :: (c -> Bool) -> l -> l + dropWhile :: (c -> Bool) -> l -> l + break :: (c -> Bool) -> l -> (l, l) + splitWhen :: (c -> Bool) -> l -> [l] + splitSeq :: Eq c => l -> l -> [l] + splitSeq = \sep lst -> + map fromList $ List.splitOn (toList sep) (toList lst) + toList :: l -> [c] + fromList :: [c] -> l + null :: l -> Bool + headMay :: l -> Maybe c + headMay = \xs -> case toList xs of + (x:_) -> Just x + _ -> Nothing + tail :: l -> l + tail = drop 1 + intercalate :: l -> [l] -> l + filter :: (c -> Bool) -> l -> l + filter = \p -> fromList . List.filter p . toList + +splitElem :: (Eq c, ListLike l c) => c -> l -> [l] +splitElem c = splitWhen (== c) + +instance ListLike [a] a where + length = List.length + take = List.take + drop = List.drop + takeWhile = List.takeWhile + dropWhile = List.dropWhile + break = List.break + splitWhen = List.splitWhen + toList = id + fromList = id + null = List.null + intercalate = List.intercalate + filter = List.filter + +instance ListLike (Vector a) a where + length = Vector.length + take = Vector.take + drop = Vector.drop + takeWhile = Vector.takeWhile + dropWhile = Vector.dropWhile + break = Vector.break + splitWhen = splitVectorWhen + toList = Vector.toList + fromList = Vector.fromList + null = Vector.null + intercalate = mintercalate + filter = Vector.filter + +mintercalate :: Monoid m => m -> [m] -> m +mintercalate _ [] = mempty +mintercalate _ [x] = x +mintercalate sep (x:xs) = x <> sep <> mintercalate sep xs + +splitVectorWhen :: (a -> Bool) -> Vector a -> [Vector a] +splitVectorWhen p v = case Vector.findIndex p v of + Nothing -> + [v] + Just index -> + let (current, remainder) = Vector.splitAt index v + in current : splitVectorWhen p remainder + +instance ListLike Text Char where + length = Text.length + take = Text.take + drop = Text.drop + takeWhile = Text.takeWhile + dropWhile = Text.dropWhile + break = Text.break + splitWhen = Text.split + toList = Text.unpack + fromList = Text.pack + null = Text.null + intercalate = Text.intercalate + filter = Text.filter + +instance ListLike LText Char where + length = fromIntegral . LText.length + take = LText.take . fromIntegral + drop = LText.drop . fromIntegral + takeWhile = LText.takeWhile + dropWhile = LText.dropWhile + break = LText.break + splitWhen = LText.split + toList = LText.unpack + fromList = LText.pack + null = LText.null + intercalate = LText.intercalate + filter = LText.filter + +instance ListLike ByteString Word8 where + length = BS.length + take = BS.take + drop = BS.drop + takeWhile = BS.takeWhile + dropWhile = BS.dropWhile + break = BS.break + splitWhen = BS.splitWith + toList = BS.unpack + fromList = BS.pack + null = BS.null + intercalate = BS.intercalate + filter = BS.filter + +instance ListLike LByteString Word8 where + length = fromIntegral . LBS.length + take = LBS.take . fromIntegral + drop = LBS.drop . fromIntegral + takeWhile = LBS.takeWhile + dropWhile = LBS.dropWhile + break = LBS.break + splitWhen = LBS.splitWith + toList = LBS.unpack + fromList = LBS.pack + null = LBS.null + intercalate = LBS.intercalate + filter = LBS.filter + +class (Monoid t, Semigroup t, IsString t) => TextLike t where + unwords :: [t] -> t + words :: t -> [t] + isPrefixOf :: t -> t -> Bool + isSuffixOf :: t -> t -> Bool + tshow :: forall a. Show a => a -> t + unlines :: [t] -> t + unlines = mintercalate "\n" + +instance TextLike [Char] where + unwords = Prelude.unwords + words = Prelude.words + isPrefixOf = List.isPrefixOf + isSuffixOf = List.isSuffixOf + tshow = show + +instance TextLike Text where + unwords = Text.unwords + words = Text.words + isPrefixOf = Text.isPrefixOf + isSuffixOf = Text.isSuffixOf + tshow = pack . show + unlines = Text.unlines + +instance TextLike LText where + unwords = LText.unwords + words = LText.words + isPrefixOf = LText.isPrefixOf + isSuffixOf = LText.isSuffixOf + tshow = pack . show + unlines = LText.unlines + +class Encode decoded encoded | decoded -> encoded, encoded -> decoded where + encodeUtf8 :: decoded -> encoded + decodeUtf8 :: encoded -> decoded + +instance Encode Text ByteString where + encodeUtf8 = Text.encodeUtf8 + decodeUtf8 = Text.decodeUtf8 + +instance Encode LText LByteString where + encodeUtf8 = LText.encodeUtf8 + decodeUtf8 = LText.decodeUtf8 + +class StrictnessConvert strict lazy | strict -> lazy, lazy -> strict where + toStrict :: lazy -> strict + fromStrict :: strict -> lazy + +instance StrictnessConvert ByteString LByteString where + toStrict = LBS.toStrict + fromStrict = LBS.fromStrict + +instance StrictnessConvert Text LText where + toStrict = LText.toStrict + fromStrict = LText.fromStrict + +class Cased t where + toUpper :: t -> t + toLower :: t -> t + +instance Cased Char where + toUpper = Char.toUpper + toLower = Char.toLower + +instance (Functor f, Cased t) => Cased (f t) where + toUpper = fmap toUpper + toLower = fmap toLower + +instance Cased Text where + toUpper = Text.toUpper + toLower = Text.toLower + +class (Semigroup s, IsString s) => FileIO s where + getContents :: IO s + readFile :: FilePath -> IO s + writeFile :: FilePath -> s -> IO () + hGetContents :: Handle -> IO s + putStr :: s -> IO () + putStrLn :: s -> IO () + putStrLn = putStr . (<> "\n") + hPutStr :: Handle -> s -> IO () + hPutStrLn :: Handle -> s -> IO () + hPutStrLn = \h -> hPutStr h . (<> "\n") + +instance FileIO String where + getContents = System.IO.getContents + readFile = System.IO.readFile + writeFile = System.IO.writeFile + hGetContents = System.IO.hGetContents + putStr = System.IO.putStr + putStrLn = System.IO.putStrLn + hPutStr = System.IO.hPutStr + hPutStrLn = System.IO.hPutStrLn + +instance FileIO Text where + getContents = Text.getContents + readFile = Text.readFile + writeFile = Text.writeFile + hGetContents = Text.hGetContents + putStr = Text.putStr + putStrLn = Text.putStrLn + hPutStr = Text.hPutStr + hPutStrLn = Text.hPutStrLn + +instance FileIO LText where + getContents = LText.getContents + readFile = LText.readFile + writeFile = LText.writeFile + hGetContents = LText.hGetContents + putStr = LText.putStr + putStrLn = LText.putStrLn + hPutStr = LText.hPutStr + hPutStrLn = LText.hPutStrLn + +instance FileIO ByteString where + getContents = BS.getContents + readFile = BS.readFile + writeFile = BS.writeFile + hGetContents = BS.hGetContents + putStr = BS.putStr + hPutStr = BS.hPutStr + +instance FileIO LByteString where + getContents = LBS.getContents + readFile = LBS.readFile + writeFile = LBS.writeFile + hGetContents = LBS.hGetContents + putStr = LBS.putStr + hPutStr = LBS.hPutStr + +hPut :: FileIO s => Handle -> s -> IO () +hPut = hPutStr + +getArgs :: (Packable t String) => IO [t] +getArgs = map pack <$> Env.getArgs + +getEnv :: (Packable v String) => String -> IO v +getEnv = fmap pack . Env.getEnv + +lookupEnv :: (Packable v String) => String -> IO (Maybe v) +lookupEnv = fmap (fmap pack) . Env.lookupEnv + +class HashDigest a where + digest :: forall t. SHA.Digest t -> a + +instance HashDigest String where + digest = SHA.showDigest + +instance HashDigest Text where + digest = pack . digest + +instance HashDigest LText where + digest = pack . digest + +instance HashDigest LByteString where + digest = SHA.bytestringDigest + +instance HashDigest ByteString where + digest = toStrict . digest + +instance HashDigest Integer where + digest = SHA.integerDigest + +sha1 :: HashDigest a => LByteString -> a +sha1 = digest . SHA.sha1 + +sha256 :: HashDigest a => LByteString -> a +sha256 = digest . SHA.sha1 + +sha512 :: HashDigest a => LByteString -> a +sha512 = digest . SHA.sha1 diff --git a/src/Web/Sprinkles/Project.hs b/src/Web/Sprinkles/Project.hs --- a/src/Web/Sprinkles/Project.hs +++ b/src/Web/Sprinkles/Project.hs @@ -6,7 +6,7 @@ module Web.Sprinkles.Project where -import ClassyPrelude +import Web.Sprinkles.Prelude hiding (readFile) import Data.Aeson as JSON import Text.Ginger ( parseGinger @@ -16,11 +16,13 @@ , GVal (..) , ToGVal (..) , (~>) + , SourcePos ) import Text.Ginger.Html (Html, htmlSource) import qualified Text.Ginger as Ginger import System.Directory (makeAbsolute, doesDirectoryExist, doesFileExist, getDirectoryContents) import System.FilePath +import System.IO (readFile) import Data.Time.Clock.POSIX (POSIXTime) import Web.Sprinkles.Exceptions @@ -32,8 +34,11 @@ import Web.Sprinkles.Cache.Filesystem (filesystemCache) import Web.Sprinkles.Cache.Memory (memCache) import Web.Sprinkles.Cache.Memcached (memcachedCache) +import Web.Sprinkles.SessionStore +import Web.Sprinkles.SessionStore.Database (sqlSessionStore, DSN (..), SqlDriver (SqliteDriver)) +import Web.Sprinkles.SessionStore.InProc (inProcSessionStore) -newtype TemplateCache = TemplateCache (HashMap Text Template) +newtype TemplateCache = TemplateCache (HashMap Text (Template SourcePos)) data Project = Project @@ -41,17 +46,30 @@ , projectTemplates :: TemplateCache , projectBackendCache :: Cache ByteString ByteString , projectLogger :: Logger + , projectSessionStore :: SessionStore + , projectSessionConfig :: SessionConfig } -loadProject :: ServerConfig -> FilePath -> IO Project -loadProject sconfig dir = do +loadProject :: ServerConfig -> IO Project +loadProject sconfig = do + let dir = scRootDir sconfig 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 + cache <- fmap mconcat + . sequence + . fmap (createCache dir) + $ scBackendCache sconfig + let sessionConfig = scSessions sconfig + sessionStore <- createSessionStore sessionConfig + return $ Project pconfig templates cache logger sessionStore sessionConfig +createSessionStore :: SessionConfig -> IO SessionStore +createSessionStore config = do + case sessDriver config of + SqlSessionDriver dsn -> sqlSessionStore dsn + InProcSessionDriver -> inProcSessionStore + _ -> return nullSessionStore createLogger :: LoggerConfig -> IO Logger createLogger DiscardLog = @@ -64,8 +82,7 @@ createCache :: FilePath -> BackendCacheConfig -> IO (Cache ByteString ByteString) createCache cwd (FilesystemCache dir expiration) = return $ filesystemCache - (unpack . decodeUtf8) -- "serialize" key - (encodeUtf8 . pack) -- "unserialize" key + (sha1 . fromStrict) -- "serialize" key hPut -- write value hGetContents -- read value (cwd dir) @@ -105,7 +122,7 @@ prefix <- makeAbsolute $ dir "templates" allFilenames <- findFilesR isTemplateFile prefix filenames <- findFiles isTemplateFile prefix - templateSources <- forM allFilenames readFile + templateSources <- forM allFilenames (readFile :: String -> IO String) let templateSourceMap :: HashMap String String templateSourceMap = mapFromList $ @@ -127,7 +144,7 @@ Right t -> return t return . TemplateCache . mapFromList $ zip (map pack relativeFilenames) templates -getTemplate :: Project -> Text -> IO Template +getTemplate :: Project -> Text -> IO (Template SourcePos) getTemplate project templateName = do let TemplateCache tm = projectTemplates project maybe diff --git a/src/Web/Sprinkles/ProjectConfig.hs b/src/Web/Sprinkles/ProjectConfig.hs --- a/src/Web/Sprinkles/ProjectConfig.hs +++ b/src/Web/Sprinkles/ProjectConfig.hs @@ -5,7 +5,7 @@ module Web.Sprinkles.ProjectConfig where -import ClassyPrelude +import Web.Sprinkles.Prelude import Web.Sprinkles.Rule import Data.Aeson as JSON import Data.Aeson.TH @@ -26,18 +26,28 @@ } deriving (Show) +makeProjectPathsAbsolute :: FilePath -> ProjectConfig -> ProjectConfig +makeProjectPathsAbsolute dir (ProjectConfig context rules) = + ProjectConfig (fmap goBackendSpec context) (fmap goRule rules) + where + goBackendSpec = makeBackendSpecPathsAbsolute dir + goRule = makeRulePathsAbsolute dir + instance Default ProjectConfig where def = ProjectConfig { pcContextData = AList.empty , pcRules = [] } +instance Semigroup ProjectConfig where + (<>) = pcAppend + instance Monoid ProjectConfig where mempty = def mappend = pcAppend instance FromJSON ProjectConfig where - parseJSON (Object obj) = do + parseJSON = withObject "ProjectConfig" $ \obj -> do contextData <- fromMaybe AList.empty <$> obj .:? "data" rulesValue <- fromMaybe (toJSON ([] :: [Value])) <$> (obj .:? "rules" <|> obj .:? "Rules") rules <- parseJSON rulesValue @@ -66,5 +76,4 @@ loadProjectConfig :: FilePath -> IO ProjectConfig loadProjectConfig dir = - loadProjectConfigFile $ dir "project.yml" - + fmap (makeProjectPathsAbsolute dir) . loadProjectConfigFile $ dir "project.yml" diff --git a/src/Web/Sprinkles/Replacement.hs b/src/Web/Sprinkles/Replacement.hs --- a/src/Web/Sprinkles/Replacement.hs +++ b/src/Web/Sprinkles/Replacement.hs @@ -11,13 +11,13 @@ ) where -import ClassyPrelude +import Web.Sprinkles.Prelude import Data.Aeson as JSON import Data.Aeson.TH as JSON import Text.Ginger ( Template - , runGinger + , runGingerT , parseGinger - , makeContextText + , makeContextTextM , ToGVal , toGVal , GVal (..) @@ -27,23 +27,25 @@ import Data.Default import Control.Monad.Writer (Writer) import Web.Sprinkles.Exceptions (formatException) +import Data.Text.Lazy.Builder as TextBuilder data ReplacementItem = Literal Text | Variable Text deriving (Show, Eq) -newtype Replacement = Replacement Template +newtype Replacement = + Replacement (Template Ginger.SourcePos) deriving (Show) -instance FromJSON Replacement where +instance FromJSON (Replacement) where parseJSON val = (either (fail . unpack . formatException) return . parseReplacement) =<< parseJSON val -expandReplacementText :: HashMap Text (GVal (Run (Writer Text) Text)) +expandReplacementText :: HashMap Text (GVal (Run Ginger.SourcePos IO Text)) -> Text - -> Either SomeException Text + -> IO Text expandReplacementText variables input = - expandReplacement variables <$> parseReplacement input + expandReplacement variables =<< either throwM return (parseReplacement input) parseReplacement :: Text -> Either SomeException Replacement parseReplacement input = @@ -53,9 +55,12 @@ 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 +expandReplacement :: HashMap Text (GVal (Run Ginger.SourcePos IO Text)) -> Replacement -> IO Text +expandReplacement variables (Replacement template) = do + output <- newIORef (TextBuilder.fromText "") + let emit :: Text -> IO () + emit t = modifyIORef' output (<> TextBuilder.fromText t) + context = makeContextTextM lookupFn emit + lookupFn varName = return . fromMaybe def $ lookup varName variables + runGingerT context template + toStrict . TextBuilder.toLazyText <$> readIORef output diff --git a/src/Web/Sprinkles/Rule.hs b/src/Web/Sprinkles/Rule.hs --- a/src/Web/Sprinkles/Rule.hs +++ b/src/Web/Sprinkles/Rule.hs @@ -6,7 +6,7 @@ module Web.Sprinkles.Rule where -import ClassyPrelude +import Web.Sprinkles.Prelude import Web.Sprinkles.Pattern import Web.Sprinkles.Replacement import Web.Sprinkles.Backends @@ -18,9 +18,10 @@ import qualified Network.HTTP.Types as HTTP import qualified Data.AList as AList import Data.AList (AList) -import Text.Ginger (Run, ToGVal (..), GVal) +import Text.Ginger (Run, ToGVal (..), GVal, SourcePos) import Control.Monad.Writer (Writer) import qualified Data.Set as Set +import Data.Expandable data RuleTarget p = TemplateTarget p | @@ -43,7 +44,23 @@ String "forever" -> return CacheForever String x -> fail $ "Invalid cache expiry: " ++ show x Number n -> return $ MaxAge (floor n) + _ -> fail "Invalid client cache setting" +-- | Describes if and how to initialize a session for a request. +data SessionDirective = AcceptSession -- ^ Accept if given, but do not require + | IgnoreSession -- ^ Ignore all sessions + | CreateNewSession -- ^ Always create a new session + | RequireSession -- ^ Require a session, fail if none exists + deriving (Eq, Show) + +instance FromJSON SessionDirective where + parseJSON = \case + String "ignore" -> return IgnoreSession + String "new" -> return CreateNewSession + String "accept" -> return AcceptSession + String "require" -> return RequireSession + _ -> fail "Invalid session directive" + data Rule = Rule { ruleRoutePattern :: Pattern @@ -53,9 +70,17 @@ , ruleAcceptedMethods :: Set HTTP.Method , ruleCaching :: ClientCacheSetting , ruleContentTypeOverride :: Maybe ByteString + , ruleSessionDirective :: SessionDirective } deriving (Show) +makeRulePathsAbsolute :: FilePath -> Rule -> Rule +makeRulePathsAbsolute dir rule = + rule + { ruleContextData = + fmap (makeBackendSpecPathsAbsolute dir) (ruleContextData rule) + } + orElse :: Monad m => m (Maybe a) -> m (Maybe a) -> m (Maybe a) orElse leftAction rightAction = do leftAction >>= maybe rightAction (return . Just) @@ -82,6 +107,7 @@ contentTypeOverride <- (fmap encodeUtf8) <$> (obj .:? "content-type") + sessionDirective <- obj .:? "session" .!= AcceptSession return $ Rule pattern contextData @@ -90,18 +116,25 @@ methods caching contentTypeOverride + sessionDirective 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 +expandRuleTarget :: HashMap Text (GVal (Run SourcePos IO Text)) -> RuleTarget Replacement -> IO (RuleTarget Text) +expandRuleTarget _ JSONTarget = + return JSONTarget +expandRuleTarget varMap (StaticTarget pMay) = + StaticTarget <$> mapM (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 +expandReplacementBackend :: HashMap Text (GVal (Run SourcePos IO Text)) -> BackendSpec -expandReplacementBackend varMap = omap (eitherThrow . expandReplacementText varMap) + -> IO BackendSpec +expandReplacementBackend varMap spec = do + bsType' <- expandM (expandReplacementText varMap) (bsType spec) + return $ spec { bsType = bsType' } data NonMatchReason = PathNotMatched | MethodNotMatched @@ -159,6 +192,6 @@ ( Rule , HashMap Text MatchedText ) -applyRules [] _ _ _ = Left PathNotMatched applyRules (rule:rules) method path query = applyRule rule method path query <|+> applyRules rules method path query +applyRules _ _ _ _ = Left PathNotMatched diff --git a/src/Web/Sprinkles/Serve.hs b/src/Web/Sprinkles/Serve.hs --- a/src/Web/Sprinkles/Serve.hs +++ b/src/Web/Sprinkles/Serve.hs @@ -6,13 +6,15 @@ {-#LANGUAGE FlexibleInstances #-} {-#LANGUAGE FlexibleContexts #-} {-#LANGUAGE MultiParamTypeClasses #-} +{-#LANGUAGE TypeApplications #-} + module Web.Sprinkles.Serve ( serveProject , appFromProject ) where -import ClassyPrelude +import Web.Sprinkles.Prelude import Control.Concurrent (forkIO) import Data.Aeson as JSON import Data.Aeson.Encode.Pretty as JSON @@ -25,7 +27,7 @@ import Data.Time.Clock.POSIX (getPOSIXTime) import Data.Yaml as YAML import Data.AList (AList) -import Data.Time (formatTime, addUTCTime, getCurrentTime) +import Data.Time (formatTime, addUTCTime, getCurrentTime, defaultTimeLocale) import Network.HTTP.Types (Status, status200, status302, status400, status404, status500) @@ -38,26 +40,26 @@ 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 qualified Text.Ginger.Run.VM 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 + (~>), SourcePos) +import Text.Ginger.Html (Html, htmlSource, unsafeRawHtml) import Web.Sprinkles.Exceptions import Web.Sprinkles.Backends import Web.Sprinkles.Cache +import Web.Sprinkles.SessionStore import Web.Sprinkles.Logger as Logger import Web.Sprinkles.Project import Web.Sprinkles.ProjectConfig import Web.Sprinkles.Rule +import Web.Sprinkles.Sessions import Web.Sprinkles.ServerConfig import Web.Sprinkles.Backends.Loader.Type - (PostBodySource (..), pbsFromRequest, pbsInvalid) + (RequestContext (..), pbsFromRequest, pbsInvalid) import Web.Sprinkles.Handlers ( handleStaticTarget , handleNotFound @@ -71,10 +73,15 @@ ( loadBackendDict , NotFoundException (..) , MethodNotAllowedException (..) + , NotAllowedException (..) , handle500 , handle404 + , handleNotAllowed + , handleRequestValidation + , marshalGValHtmlToText ) import Web.Sprinkles.MatchedText (MatchedText (..)) +import Web.Sprinkles.TemplateContext (sprinklesGingerContext) serveProject :: ServerConfig -> Project -> IO () serveProject config project = do @@ -87,6 +94,7 @@ CGIDriver -> serveCGI SCGIDriver -> serveSCGI FastCGIDriver -> serveFastCGI + BakeDriver -> serveWarp Nothing vacuum = forever $ do itemsCleared <- cacheVacuum (projectBackendCache project) when (itemsCleared > 0) $ @@ -101,8 +109,8 @@ port <- case portMay of Just p -> return p Nothing -> do - portEnvStr <- lookupEnv "PORT" - let portEnv = fromMaybe 5000 $ portEnvStr >>= readMay + portEnvStr <- lookupEnv ("PORT" :: String) + let portEnv = fromMaybe 5000 $ portEnvStr >>= readMay @Int @String return portEnv writeLog (projectLogger project) Notice $ "Running server on port " <> tshow port <> "..." @@ -140,6 +148,7 @@ handleRequest project request respond = go `catch` handleNotFound project request respond `catch` handleMethodNotAllowed project request respond + `catch` handleRequestValidation project request respond `catch` \e -> handle500 e project request respond where go = do @@ -166,12 +175,24 @@ handleRule :: Rule -> HashMap Text MatchedText -> Project -> Wai.Application handleRule rule captures project request respond = do + session <- case ruleSessionDirective rule of + IgnoreSession -> return Nothing + AcceptSession -> resumeSession project request + RequireSession -> resumeSession project request >>= \case + Nothing -> throwM NotAllowedException + Just s -> return $ Just s + CreateNewSession -> return Nothing + + newSession <- case ruleSessionDirective rule of + CreateNewSession -> newSession project request + _ -> return session + let cache = projectBackendCache project capturesG = fmap toGVal captures globalBackendSpecs = pcContextData . projectConfig $ project backendSpecs = ruleContextData $ rule - target = expandRuleTarget capturesG . ruleTarget $ rule logger = projectLogger project + context <- (capturesG <>) <$> sprinklesGingerContext cache request newSession logger now <- getCurrentTime let oneYear = 86400 * 365 -- good enough @@ -181,7 +202,7 @@ MaxAge seconds -> addUTCTime (fromInteger seconds) now let respond' :: Wai.Response -> IO Wai.ResponseReceived - respond' = respond . addExpiryHeader . overrideContentType + respond' = respond . addCookie . addExpiryHeader . overrideContentType overrideContentType :: Wai.Response -> Wai.Response overrideContentType = @@ -194,6 +215,9 @@ x -> x ) + addCookie :: Wai.Response -> Wai.Response + addCookie = maybe id (setSessionCookie project request) newSession + addExpiryHeader :: Wai.Response -> Wai.Response addExpiryHeader = let expiryHeader = @@ -205,17 +229,24 @@ ) in mapResponseHeaders (expiryHeader:) - backendData :: HashMap Text (Items (BackendData IO Html)) + backendData :: HashMap Text (Items (BackendData SourcePos IO Html)) <- loadBackendDict (writeLog logger) - (pbsFromRequest request) + (pbsFromRequest request session) cache (globalBackendSpecs <> backendSpecs) (ruleRequired rule) - capturesG + context - let handle :: HashMap Text (Items (BackendData IO Html)) + let context' :: HashMap Text (GVal (Ginger.Run SourcePos IO Html)) + context' = fmap toGVal backendData + context'' :: HashMap Text (GVal (Ginger.Run SourcePos IO Text)) + context'' = fmap marshalGValHtmlToText context' + target <- expandRuleTarget (context'' <> context) . ruleTarget $ rule + + let handle :: HashMap Text (Items (BackendData SourcePos IO Html)) -> Project + -> Maybe SessionHandle -> Wai.Application handle = case target of RedirectTarget redirectPath -> @@ -235,5 +266,6 @@ handle backendData project + session request respond' diff --git a/src/Web/Sprinkles/ServerConfig.hs b/src/Web/Sprinkles/ServerConfig.hs --- a/src/Web/Sprinkles/ServerConfig.hs +++ b/src/Web/Sprinkles/ServerConfig.hs @@ -7,7 +7,7 @@ module Web.Sprinkles.ServerConfig where -import ClassyPrelude +import Web.Sprinkles.Prelude import Web.Sprinkles.Rule import Data.Aeson as JSON import Data.Aeson.TH @@ -15,13 +15,13 @@ 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 +import Web.Sprinkles.Databases (DSN (..), SqlDriver (..)) data BackendCacheConfig = FilesystemCache FilePath POSIXTime | @@ -54,6 +54,7 @@ | CGIDriver | SCGIDriver | FastCGIDriver + | BakeDriver | DefaultDriver deriving (Show, Read, Eq) @@ -71,8 +72,12 @@ return FastCGIDriver parseJSON (String "scgi") = return SCGIDriver + parseJSON (String "bake") = + return BakeDriver parseJSON (String "default") = return def + parseJSON (String x) = + fail $ "Invalid server driver " ++ show x parseJSON (Object o) = do st :: Text <- o .: "type" case st of @@ -81,6 +86,10 @@ "fcgi" -> return FastCGIDriver "fastcgi" -> return FastCGIDriver "scgi" -> return SCGIDriver + "bake" -> return BakeDriver + x -> fail $ "Invalid server driver " ++ show x + parseJSON x = + fail $ "Invalid server driver " ++ show x data LoggerConfig = DiscardLog | @@ -99,14 +108,72 @@ StdioLog . fromMaybe Warning <$> obj .:? "level" Just "syslog" -> Syslog . fromMaybe Warning <$> obj .:? "level" - + Just x -> fail $ "Invalid logger type " ++ show x parseJSON _ = fail "Invalid logger config" +data SessionExpiration = NeverExpire + | SlidingExpiration Integer + deriving (Show) + +instance FromJSON SessionExpiration where + parseJSON = \case + Number n -> return . SlidingExpiration . floor $ n + Null -> return NeverExpire + String "never" -> return NeverExpire + _ -> fail "Invalid session expiration" + +data SessionDriver = NoSessionDriver + | InProcSessionDriver + | SqlSessionDriver DSN + deriving (Show) + +instance FromJSON SessionDriver where + parseJSON = \case + Null -> return NoSessionDriver + String "inproc" -> return InProcSessionDriver + String "sql" -> return $ SqlSessionDriver (DSN SqliteDriver "sessions.sqlite") + String x -> fail $ "Invalid session driver " ++ show x + Object obj -> do + ty <- obj .: "type" + case (ty :: Text) of + "inproc" -> + return InProcSessionDriver + "sql" -> do + SqlSessionDriver <$> + obj .:? "connection" .!= DSN SqliteDriver "sessions.sqlite" + x -> fail $ "Invalid session driver " ++ show x + _ -> fail "Invalid session driver" + +data SessionConfig = + SessionConfig + { sessCookieName :: ByteString + , sessCookieSecure :: Bool + , sessExpiration :: SessionExpiration + , sessDriver :: SessionDriver + } + deriving (Show) + +instance FromJSON SessionConfig where + parseJSON (Object obj) = do + cookieName <- encodeUtf8 <$> obj .:? "cookie-name" .!= "ssid" + expiration <- obj .:? "expiration" .!= NeverExpire + secure <- obj .:? "secure" .!= True -- secure default + driver <- obj .:? "driver" .!= InProcSessionDriver + return $ SessionConfig cookieName secure expiration driver + parseJSON x = do + driver <- parseJSON x + return $ SessionConfig "ssid" True NeverExpire driver + +instance Default SessionConfig where + def = SessionConfig "ssid" True NeverExpire NoSessionDriver + data ServerConfig = ServerConfig { scBackendCache :: [BackendCacheConfig] , scDriver :: ServerDriver , scLogger :: Maybe LoggerConfig + , scSessions :: SessionConfig + , scRootDir :: FilePath } deriving (Show) @@ -115,8 +182,13 @@ { scBackendCache = def , scDriver = def , scLogger = Nothing + , scSessions = def + , scRootDir = "" } +instance Semigroup ServerConfig where + (<>) = scAppend + instance Monoid ServerConfig where mempty = def mappend = scAppend @@ -130,10 +202,14 @@ driver <- fromMaybe def <$> ( obj .:? "driver" ) logger <- obj .:? "log" + sessions <- obj .:? "sessions" .!= def + rootDir <- obj .:? "dir" .!= "" return ServerConfig { scBackendCache = caches , scDriver = driver , scLogger = logger + , scSessions = sessions + , scRootDir = rootDir } parseJSON _ = fail "Invalid server config" @@ -147,6 +223,12 @@ if scDriver b == DefaultDriver then scDriver a else scDriver b + , scSessions = + case sessDriver (scSessions b) of + NoSessionDriver -> scSessions a + _ -> scSessions b + , scRootDir = + firstNonNull (scRootDir b) (scRootDir a) } firstNonNull :: [a] -> [a] -> [a] @@ -162,7 +244,7 @@ loadServerConfig :: FilePath -> IO ServerConfig loadServerConfig dir = do - homeDirMay <- lookupEnv "HOME" + homeDirMay <- lookupEnv ("HOME" :: String) let systemGlobalFilename = "/etc/sprinkles/server.yml" globalFilename = "/usr/local/etc/sprinkles/server.yml" userFilenameMay = ( ".config" "sprinkles" "server.yml") <$> homeDirMay diff --git a/src/Web/Sprinkles/SessionHandle.hs b/src/Web/Sprinkles/SessionHandle.hs new file mode 100644 --- /dev/null +++ b/src/Web/Sprinkles/SessionHandle.hs @@ -0,0 +1,66 @@ +{-#LANGUAGE NoImplicitPrelude #-} +{-#LANGUAGE OverloadedStrings #-} +{-#LANGUAGE OverloadedLists #-} +{-#LANGUAGE LambdaCase #-} +{-#LANGUAGE ScopedTypeVariables #-} +{-#LANGUAGE FlexibleInstances #-} +{-#LANGUAGE FlexibleContexts #-} +{-#LANGUAGE MultiParamTypeClasses #-} +{-#LANGUAGE TypeApplications #-} +module Web.Sprinkles.SessionHandle +( SessionHandle (..) +, makeSessionHandle +) +where + +import Web.Sprinkles.Prelude +import Web.Sprinkles.SessionStore +import Text.Ginger + (GVal(..), ToGVal(..), + (~>)) +import qualified Text.Ginger as Ginger +import Data.Default + +data SessionHandle = + SessionHandle + { sessionID :: SessionID + , sessionGet :: Text -> IO (Maybe Text) + , sessionPut :: Text -> Text -> IO () + } + +instance (Monad m, MonadIO m) => ToGVal (Ginger.Run p m h) SessionHandle where + toGVal session = + Ginger.dict + [ "id" ~> decodeUtf8 @Text (sessionID session) + , ("get", Ginger.fromFunction (gSessionGet $ session)) + , ("put", Ginger.fromFunction (gSessionPut $ session)) + ] + +gSessionGet :: (Monad m, MonadIO m) => SessionHandle -> Ginger.Function (Ginger.Run p m h) +gSessionGet session args = do + let (matched, position, named) = Ginger.matchFuncArgs ["key"] args + case lookup "key" matched of + Nothing -> + return def + Just key -> do + toGVal <$> liftIO (sessionGet session $ Ginger.asText key) + +gSessionPut :: (Monad m, MonadIO m) => SessionHandle -> Ginger.Function (Ginger.Run p m h) +gSessionPut session args = do + let (matched, position, named) = Ginger.matchFuncArgs ["key", "value"] args + case lookup "key" matched of + Nothing -> + return def + Just key -> do + liftIO $ sessionPut session + (Ginger.asText key) + (Ginger.asText . fromMaybe def $ lookup "value" matched) + return def + +makeSessionHandle :: SessionStore -> SessionID -> SessionHandle +makeSessionHandle ss ssid = + SessionHandle + { sessionID = ssid + , sessionGet = ssGet ss ssid + , sessionPut = ssPut ss ssid + } diff --git a/src/Web/Sprinkles/SessionStore.hs b/src/Web/Sprinkles/SessionStore.hs new file mode 100644 --- /dev/null +++ b/src/Web/Sprinkles/SessionStore.hs @@ -0,0 +1,60 @@ +{-#LANGUAGE NoImplicitPrelude #-} +{-#LANGUAGE OverloadedStrings #-} +{-#LANGUAGE OverloadedLists #-} +{-#LANGUAGE LambdaCase #-} +{-#LANGUAGE TupleSections #-} +module Web.Sprinkles.SessionStore +where + +import Web.Sprinkles.Prelude +import Data.Time.Clock.POSIX + +type SessionID = ByteString + +data SessionExpiry = NeverExpires | Expires POSIXTime + deriving (Show, Eq) + +data SessionNotFoundException = SessionNotFoundException + deriving (Show) + +instance Exception SessionNotFoundException where + +data SessionSupportDisabled = SessionSupportDisabled + deriving (Show) + +instance Exception SessionSupportDisabled where + +-- | Common interface for session store backends. +data SessionStore = + SessionStore + { ssGet :: SessionID -> Text -> IO (Maybe Text) + -- ^ Attempt to retrieve a value from a session + , ssList :: SessionID -> IO [Text] + -- ^ List all the keys in the session + , ssGetAll :: SessionID -> IO [(Text,Text)] + -- ^ Retrieve the entire session contents (key, value) + , ssPut :: SessionID -> Text -> Text -> IO () + -- ^ Store a value in a session. Fail if session does not exist. + , ssCreateSession :: SessionID -> SessionExpiry -> IO () + -- ^ Create a new session + , ssDropSession :: SessionID -> IO () + -- ^ Drop a session and delete its associated data + , ssDoesSessionExist :: SessionID -> IO Bool + -- ^ Checks if a session exists + + -- , ssTouchSession :: SessionID -> IO () + -- -- ^ Shift a session's expiry timestamp to current time + expiry + -- , ssVacuum :: IO () + -- -- ^ Drop all expired sessions + } + +nullSessionStore = + SessionStore + { ssGet = const . const $ return Nothing + , ssList = const $ return [] + , ssGetAll = const $ return [] + , ssPut = const . const . const $ return () + , ssCreateSession = const . const $ throwM SessionSupportDisabled + , ssDropSession = const $ return () + , ssDoesSessionExist = const $ return False + } diff --git a/src/Web/Sprinkles/SessionStore/Database.hs b/src/Web/Sprinkles/SessionStore/Database.hs new file mode 100644 --- /dev/null +++ b/src/Web/Sprinkles/SessionStore/Database.hs @@ -0,0 +1,153 @@ +{-#LANGUAGE NoImplicitPrelude #-} +{-#LANGUAGE OverloadedStrings #-} +{-#LANGUAGE OverloadedLists #-} +{-#LANGUAGE LambdaCase #-} +{-#LANGUAGE TupleSections #-} +{-#LANGUAGE QuasiQuotes #-} +{-#LANGUAGE RankNTypes #-} +module Web.Sprinkles.SessionStore.Database +( sqlSessionStore +, DSN (..) +, SqlDriver (..) +) +where + +import Web.Sprinkles.Prelude +import qualified Database.HDBC as HDBC +import qualified Web.Sprinkles.Databases as DB +import Web.Sprinkles.Databases (DSN (..), SqlDriver (..)) +import Web.Sprinkles.SessionStore +import Text.Heredoc (here) +import Database.YeshQL.HDBC + +sqlSessionStore :: DSN -> IO SessionStore +sqlSessionStore dsn = do + conn <- sdbSetup dsn + return SessionStore + { ssGet = sdbGet conn + , ssGetAll = sdbGetAll conn + , ssList = sdbList conn + , ssPut = sdbPut conn + , ssCreateSession = sdbCreate conn + , ssDropSession = sdbDrop conn + , ssDoesSessionExist = sdbExists conn + } + +sdbSetup :: DSN -> IO HDBC.ConnWrapper +sdbSetup dsn = do + conn <- DB.connect dsn + HDBC.withTransaction conn $ \conn -> do + HDBC.runRaw conn [here| + CREATE TABLE IF NOT EXISTS sessions + ( ssid VARCHAR NOT NULL + ) |] + HDBC.withTransaction conn $ \conn -> do + HDBC.runRaw conn [here| + CREATE TABLE IF NOT EXISTS session_data + ( ssid VARCHAR NOT NULL + , skey VARCHAR NOT NULL + , sval VARCHAR NOT NULL + , PRIMARY KEY (ssid, skey) + , FOREIGN KEY (ssid) + REFERENCES sessions (ssid) + ON DELETE CASCADE + ON UPDATE CASCADE + ); + |] + return conn + +[yesh| + -- name:get :: (Text) + -- :ssid :: ByteString + -- :skey :: Text + SELECT sval + FROM session_data + WHERE ssid = :ssid + AND skey = :skey LIMIT 1 + + ;;; + + -- name:getAll :: [(Text, Text)] + -- :ssid :: ByteString + SELECT skey, sval + FROM session_data + WHERE ssid = :ssid + + ;;; + + -- name:listKeys :: [(Text)] + -- :ssid :: ByteString + SELECT skey + FROM session_data + WHERE ssid = :ssid + + ;;; + + -- name:put :: rowcount Int + -- :ssid :: ByteString + -- :skey :: Text + -- :sval :: Text + INSERT INTO session_data (ssid, skey, sval) + SELECT ssid, :skey, :sval + FROM sessions WHERE ssid = :ssid + + ;;; + + -- name:dropSession :: rowcount Int + -- :ssid :: ByteString + DELETE FROM sessions WHERE ssid = :ssid + + ;;; + + -- name:createSession :: rowcount Int + -- :ssid :: ByteString + INSERT INTO sessions (ssid) + VALUES (:ssid) + + ;;; + + -- name:sessionExists :: (Bool) + -- :ssid :: ByteString + SELECT COUNT(1) FROM sessions WHERE ssid = :ssid +|] + +withDB :: HDBC.ConnWrapper + -> (HDBC.ConnWrapper -> IO a) + -> IO a +withDB conn inner = do + conn' <- HDBC.clone conn + HDBC.withTransaction conn' inner + +sdbGet :: HDBC.ConnWrapper -> SessionID -> Text -> IO (Maybe Text) +sdbGet conn ssid skey = + withDB conn $ get ssid skey + +sdbList :: HDBC.ConnWrapper -> SessionID -> IO [Text] +sdbList conn ssid = + withDB conn $ listKeys ssid + +sdbGetAll :: HDBC.ConnWrapper -> SessionID -> IO [(Text, Text)] +sdbGetAll conn ssid = + withDB conn $ getAll ssid + +sdbPut :: HDBC.ConnWrapper -> SessionID -> Text -> Text -> IO () +sdbPut conn ssid skey sval = + (withDB conn $ put ssid skey sval) >>= \case + 1 -> return () + 0 -> throwM SessionNotFoundException + _ -> error "More than one session with the same key. This is strange." + +sdbCreate :: HDBC.ConnWrapper -> SessionID -> SessionExpiry -> IO () +sdbCreate conn ssid expiry = + (withDB conn $ createSession ssid) >>= \case + 1 -> return () + 0 -> error "Session creation failed" + _ -> error "More than one session created. This is strange." + +sdbDrop :: HDBC.ConnWrapper -> SessionID -> IO () +sdbDrop conn ssid = + (withDB conn $ dropSession ssid) >> return () + +sdbExists :: HDBC.ConnWrapper -> SessionID -> IO Bool +sdbExists conn ssid = + fmap (fromMaybe False) . withDB conn $ sessionExists ssid diff --git a/src/Web/Sprinkles/SessionStore/InProc.hs b/src/Web/Sprinkles/SessionStore/InProc.hs new file mode 100644 --- /dev/null +++ b/src/Web/Sprinkles/SessionStore/InProc.hs @@ -0,0 +1,81 @@ +{-#LANGUAGE NoImplicitPrelude #-} +{-#LANGUAGE OverloadedStrings #-} +{-#LANGUAGE OverloadedLists #-} +{-#LANGUAGE LambdaCase #-} +{-#LANGUAGE TupleSections #-} +{-#LANGUAGE QuasiQuotes #-} +{-#LANGUAGE RankNTypes #-} +module Web.Sprinkles.SessionStore.InProc +( inProcSessionStore +) +where + +import Web.Sprinkles.Prelude hiding (atomically) +import Web.Sprinkles.SessionStore +import Control.Concurrent.STM + +inProcSessionStore :: IO SessionStore +inProcSessionStore = do + db <- newDB + return SessionStore + { ssGet = dbGet db + , ssGetAll = dbGetAll db + , ssList = dbList db + , ssPut = dbPut db + , ssCreateSession = dbCreate db + , ssDropSession = dbDrop db + , ssDoesSessionExist = dbExists db + } + +type DB = TVar (HashMap SessionID (TVar Session)) + +type Session = HashMap Text Text + +newDB :: IO DB +newDB = newTVarIO $ mapFromList [] + +dbCreate :: DB -> SessionID -> SessionExpiry -> IO () +dbCreate db ssid expiry = atomically $ do + session <- newTVar $ mapFromList [] + modifyTVar db $ insertMap ssid session + +dbDrop :: DB -> SessionID -> IO () +dbDrop db ssid = atomically $ + modifyTVar db (deleteMap ssid) + +dbExists :: DB -> SessionID -> IO Bool +dbExists db ssid = atomically $ + isJust <$> dbGetSession db ssid + +dbGetSessionVar :: DB -> SessionID -> STM (Maybe (TVar Session)) +dbGetSessionVar db ssid = lookup ssid <$> readTVar db + +dbGetSession :: DB -> SessionID -> STM (Maybe Session) +dbGetSession db ssid = do + dbGetSessionVar db ssid >>= maybe + (return Nothing) + (fmap Just . readTVar) + +dbWithSession :: DB -> SessionID -> (Session -> STM (Maybe a)) -> (STM (Maybe a)) +dbWithSession db ssid inner = + dbGetSession db ssid >>= maybe + (return Nothing) + inner + +dbGet :: DB -> SessionID -> Text -> IO (Maybe Text) +dbGet db ssid k = atomically $ do + dbWithSession db ssid $ return . lookup k + +dbGetAll :: DB -> SessionID -> IO [(Text, Text)] +dbGetAll db ssid = atomically $ do + fmap (fromMaybe []) . dbWithSession db ssid $ return . Just . mapToList + +dbList :: DB -> SessionID -> IO [Text] +dbList db ssid = atomically $ do + fmap (fromMaybe []) . dbWithSession db ssid $ return . Just . keys + +dbPut :: DB -> SessionID -> Text -> Text -> IO () +dbPut db ssid k v = atomically $ do + dbGetSessionVar db ssid >>= maybe + (throwM SessionNotFoundException) + (flip modifyTVar $ insertMap k v) diff --git a/src/Web/Sprinkles/Sessions.hs b/src/Web/Sprinkles/Sessions.hs new file mode 100644 --- /dev/null +++ b/src/Web/Sprinkles/Sessions.hs @@ -0,0 +1,95 @@ +{-#LANGUAGE NoImplicitPrelude #-} +{-#LANGUAGE OverloadedStrings #-} +{-#LANGUAGE OverloadedLists #-} +{-#LANGUAGE LambdaCase #-} +{-#LANGUAGE ScopedTypeVariables #-} +{-#LANGUAGE FlexibleInstances #-} +{-#LANGUAGE FlexibleContexts #-} +{-#LANGUAGE MultiParamTypeClasses #-} +module Web.Sprinkles.Sessions +( SessionHandle +, sessionID +, sessionGet +, sessionPut +, resumeSession +, newSession +, setSessionCookie +) +where + +import Web.Sprinkles.Prelude +import Web.Sprinkles.SessionStore +import Web.Sprinkles.SessionHandle +import Web.Sprinkles.Logger as Logger +import Web.Sprinkles.Project +import Web.Sprinkles.ProjectConfig +import Web.Sprinkles.ServerConfig +import Network.Wai +import qualified Data.ByteString.Char8 as Char8 +import Data.Char (isSpace) +import qualified Crypto.Nonce as Nonce +import Data.RandomString (randomStr) + +setSessionCookie :: Project -> Request -> SessionHandle -> Response -> Response +setSessionCookie project request session = + let sessionConfig = projectSessionConfig project + cookieValue = mconcat [ (sessCookieName sessionConfig) + , "=" + , (sessionID session) + ] + cookieHeader = ("Set-Cookie", cookieValue) + in mapResponseHeaders (cookieHeader:) + + +resumeSession :: Project -> Request -> IO (Maybe SessionHandle) +resumeSession project request = do + let sessionConfig = projectSessionConfig project + sessionStore = projectSessionStore project + let cookieHeaderMay = lookup "Cookie" (requestHeaders request) + maybe (return Nothing) (loadSession sessionStore) $ + cookieHeaderMay >>= + parseCookieHeader >>= + lookup (sessCookieName sessionConfig) + +verifyCSRF :: Project -> Request -> IO Bool +verifyCSRF project request = do + let sessionConfig = projectSessionConfig project + sessionStore = projectSessionStore project + resumeSession project request >>= \case + Nothing -> + return False + Just handle -> do + let csrfHeaderMay = decodeUtf8 <$> lookup "X-Form-Token" (requestHeaders request) + csrfTokenMay <- sessionGet handle "csrf" + return $ + (csrfHeaderMay == csrfTokenMay) && + isJust csrfHeaderMay + +newSession :: Project -> Request -> IO (Maybe SessionHandle) +newSession project request = do + ssid <- Nonce.new >>= Nonce.nonce128url + csrfToken <- Nonce.new >>= Nonce.nonce128url + let sessionConfig = projectSessionConfig project + sessionStore = projectSessionStore project + ssCreateSession sessionStore ssid NeverExpires + let handle = makeSessionHandle sessionStore ssid + sessionPut handle "csrf" . decodeUtf8 $ csrfToken + return . Just $ handle + +parseCookieHeader :: ByteString -> Maybe [(ByteString, ByteString)] +parseCookieHeader headerVal = + let parts = map (Char8.dropWhile isSpace) $ + Char8.split ';' headerVal + splitOnce sep str = + let (a, b) = Char8.break (== sep) str + in (a, Char8.drop 1 b) + in Just (map (splitOnce '=') parts) + +loadSession :: SessionStore -> ByteString -> IO (Maybe SessionHandle) +loadSession ss ssid = do + exists <- ssDoesSessionExist ss ssid + if exists + then + return . Just $ makeSessionHandle ss ssid + else + return Nothing diff --git a/src/Web/Sprinkles/TemplateContext.hs b/src/Web/Sprinkles/TemplateContext.hs new file mode 100644 --- /dev/null +++ b/src/Web/Sprinkles/TemplateContext.hs @@ -0,0 +1,289 @@ +{-#LANGUAGE DeriveGeneric #-} +{-#LANGUAGE NoImplicitPrelude #-} +{-#LANGUAGE OverloadedStrings #-} +{-#LANGUAGE OverloadedLists #-} +{-#LANGUAGE LambdaCase #-} +{-#LANGUAGE ScopedTypeVariables #-} +{-#LANGUAGE FlexibleInstances #-} +{-#LANGUAGE FlexibleContexts #-} +{-#LANGUAGE MultiParamTypeClasses #-} +{-#LANGUAGE TypeApplications #-} + +module Web.Sprinkles.TemplateContext +where + +import Web.Sprinkles.Prelude +import Text.Ginger + (parseGinger, Template, runGingerT, GingerContext, GVal(..), ToGVal(..), + (~>)) +import Text.Ginger.Html + (unsafeRawHtml, html) +import qualified Text.Ginger as Ginger +import qualified Data.Yaml as YAML +import Data.Aeson (ToJSON (..), FromJSON (..)) +import qualified Data.Aeson as JSON +import qualified Data.Aeson.Types 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.CustomCreole as PandocCreole +import qualified Data.ByteString.UTF8 as UTF8 +import qualified Data.ByteString.Lazy.UTF8 as LUTF8 +import Data.ByteString.Builder (stringUtf8) +import qualified Network.Wai as Wai +import qualified Data.CaseInsensitive as CI +import Network.HTTP.Types.URI (queryToQueryText) +import qualified Crypto.BCrypt as BCrypt +import Control.Monad.Except (throwError) + +import Web.Sprinkles.Pandoc (pandocReaderOptions) +import Web.Sprinkles.Backends +import Web.Sprinkles.Backends.Spec (backendSpecFromJSON) +import Web.Sprinkles.Exceptions +import Web.Sprinkles.Logger as Logger +import Web.Sprinkles.Backends.Loader.Type + (RequestContext (..), pbsFromRequest, pbsInvalid) +import Web.Sprinkles.SessionHandle +import Data.RandomString (randomStr) + +import Text.Printf (printf) + +sprinklesGingerContext :: RawBackendCache + -> Wai.Request + -> Maybe SessionHandle + -> Logger + -> IO (HashMap Text (GVal (Ginger.Run p IO h))) +sprinklesGingerContext cache request session logger = do + csrfTokenMay <- case session of + Nothing -> return Nothing + Just handle -> sessionGet handle "csrf" + writeLog logger Debug . pack . printf "CSRF token: %s" . show $ csrfTokenMay + let csrfTokenInput = case csrfTokenMay of + Just token -> + mconcat + [ unsafeRawHtml "" + ] + Nothing -> + unsafeRawHtml "" + return $ mapFromList + [ "request" ~> request + , "session" ~> session + , "formToken" ~> csrfTokenMay + , "formTokenInput" ~> csrfTokenInput + , ("load", Ginger.fromFunction (gfnLoadBackendData (writeLog logger) cache)) + ] <> baseGingerContext logger + +baseGingerContext :: Logger + -> HashMap Text (GVal (Ginger.Run p IO h)) +baseGingerContext logger = + mapFromList + [ ("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))) + , ("bcrypt", gnsBCrypt) + , ("randomStr", Ginger.fromFunction gfnRandomStr) + ] + +gnsBCrypt :: GVal (Ginger.Run p IO h) +gnsBCrypt = + Ginger.dict + [ ("hash", Ginger.fromFunction gfnBCryptHash) + , ("validate", Ginger.fromFunction gfnBCryptValidate) + ] + +gfnBCryptHash :: Ginger.Function (Ginger.Run p IO h) +gfnBCryptHash args = do + let argSpec :: [(Text, Ginger.GVal (Ginger.Run p IO h))] + argSpec = [ ("password", def) + , ("cost", toGVal (4 :: Int)) + , ("algorithm", toGVal ("$2y$" :: Text)) + ] + case Ginger.extractArgsDefL argSpec args of + Right [passwordG, costG, algorithmG] -> do + let password = encodeUtf8 . Ginger.asText $ passwordG + algorithm = encodeUtf8 . Ginger.asText $ algorithmG + cost <- maybe + (throwM $ GingerInvalidFunctionArgs "bcrypt.hash" "int cost") + (return . ceiling) + (asNumber costG) + let policy = BCrypt.HashingPolicy cost algorithm + hash <- liftIO $ BCrypt.hashPasswordUsingPolicy policy password + return . toGVal . fmap decodeUtf8 $ hash + _ -> throwM $ GingerInvalidFunctionArgs "bcrypt.hash" "string password, int cost, string algorithm" + +gfnRandomStr :: Ginger.Function (Ginger.Run p IO h) +gfnRandomStr args = do + let defaultAlphabet = ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] :: String + argSpec :: [(Text, Ginger.GVal (Ginger.Run p IO h))] + argSpec = [ ("length", toGVal (8 :: Int)) + , ("alphabet", toGVal defaultAlphabet) + ] + case Ginger.extractArgsDefL argSpec args of + Right [lengthG, alphabetG] -> do + desiredLength :: Int <- case fmap round . asNumber $ lengthG of + Nothing -> throwM $ GingerInvalidFunctionArgs "randomStr" "int length" + Just l -> return l + let alphabet :: String + alphabet = unpack . Ginger.asText $ alphabetG + when (null alphabet) + (throwM $ GingerInvalidFunctionArgs "randomStr" "alphabet too small") + liftIO $ toGVal <$> randomStr alphabet desiredLength + _ -> throwM $ GingerInvalidFunctionArgs "randomStr" "int length, string alphabet" + +gfnBCryptValidate :: Ginger.Function (Ginger.Run p IO h) +gfnBCryptValidate args = do + let argSpec :: [(Text, Ginger.GVal (Ginger.Run p IO h))] + argSpec = [ ("hash", def) + , ("password", def) + ] + case Ginger.extractArgsDefL argSpec args of + Right [hashG, passwordG] -> do + let hash = encodeUtf8 . Ginger.asText $ hashG + password = encodeUtf8 . Ginger.asText $ passwordG + return . toGVal $ BCrypt.validatePassword hash password + _ -> throwM $ GingerInvalidFunctionArgs "bcrypt.validate" "string password, int cost, string algorithm" + +gfnPandoc :: forall p h. (LogLevel -> Text -> IO ()) -> Ginger.Function (Ginger.Run p 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 p h. Text -> (LogLevel -> Text -> IO ()) -> Ginger.Function (Ginger.Run p 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.TextReader r -> + r pandocReaderOptions + Pandoc.ByteStringReader r -> + r pandocReaderOptions . encodeUtf8 . fromStrict + (pure . Pandoc.runPure . read $ src) >>= either + (\err -> fail $ "Reading " ++ show readerName ++ " failed: " ++ show err) + return + where + getReader :: String -> Either String (Pandoc.Reader Pandoc.PandocPure) + getReader "creole-tdammers" = customCreoleReader + getReader readerName = fst <$> Pandoc.getReader readerName + +customCreoleReader :: Either String (Pandoc.Reader Pandoc.PandocPure) +customCreoleReader = + Right . Pandoc.TextReader $ reader + where + reader :: Pandoc.ReaderOptions -> Text -> Pandoc.PandocPure Pandoc.Pandoc + reader opts src = + either throwError return $ + PandocCreole.readCustomCreole opts (unpack src) + +gfnGetLocale :: forall p h. (LogLevel -> Text -> IO ()) -> Ginger.Function (Ginger.Run p 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 p 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 = Web.Sprinkles.Prelude.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 p IO h) +gfnJSON ((_, x):_) = + return . toGVal . LUTF8.toString . JSON.encodePretty $ x +gfnJSON _ = + return def + +gfnYAML :: Ginger.Function (Ginger.Run p IO h) +gfnYAML ((_, x):_) = + return . toGVal . UTF8.toString . YAML.encode $ x +gfnYAML _ = + return def + +gfnLoadBackendData :: forall p h. (LogLevel -> Text -> IO ()) -> RawBackendCache -> Ginger.Function (Ginger.Run p IO h) +gfnLoadBackendData writeLog cache args = + Ginger.dict <$> forM (zip [0..] args) loadPair + where + loadPair :: (Int, (Maybe Text, GVal (Ginger.Run p IO h))) + -> Ginger.Run p IO h (Text, GVal (Ginger.Run p IO h)) + loadPair (index, (keyMay, gBackendURL)) = do + backendSpec <- either fail pure . JSON.parseEither backendSpecFromJSON . toJSON $ gBackendURL + backendData :: Items (BackendData p IO h) <- liftIO $ + loadBackendData writeLog pbsInvalid cache backendSpec + return + ( fromMaybe (tshow @Text 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 + ) + +instance ToGVal m Wai.Request where + toGVal rq = + Ginger.orderedDict + [ "httpVersion" ~> tshow @Text (Wai.httpVersion rq) + , "method" ~> decodeUtf8 @Text (Wai.requestMethod rq) + , "path" ~> decodeUtf8 @Text (Wai.rawPathInfo rq) + , "query" ~> decodeUtf8 @Text (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 + diff --git a/test/Web/Sprinkles/ApplicationTest.hs b/test/Web/Sprinkles/ApplicationTest.hs --- a/test/Web/Sprinkles/ApplicationTest.hs +++ b/test/Web/Sprinkles/ApplicationTest.hs @@ -4,8 +4,9 @@ module Web.Sprinkles.ApplicationTest where -import ClassyPrelude +import Web.Sprinkles.Prelude import Web.Sprinkles.Project (Project (..), loadProject) +import Web.Sprinkles.ServerConfig (ServerConfig (..)) import Web.Sprinkles.Serve (appFromProject) import Web.Sprinkles.Logger (Logger (..), LogMessage (..), tChanLogger) import System.Directory @@ -62,9 +63,9 @@ go :: FilePath -> IO () go dir = do - let sconfig = def + let sconfig = def { scRootDir = "." } logChan <- newTChanIO - project <- setFakeLogger logChan <$> loadProject sconfig "." + project <- setFakeLogger logChan <$> loadProject sconfig inner project setFakeLogger :: TChan LogMessage -> Project -> Project diff --git a/test/Web/Sprinkles/PatternTest.hs b/test/Web/Sprinkles/PatternTest.hs --- a/test/Web/Sprinkles/PatternTest.hs +++ b/test/Web/Sprinkles/PatternTest.hs @@ -3,7 +3,7 @@ module Web.Sprinkles.PatternTest where -import ClassyPrelude +import Web.Sprinkles.Prelude hiding (Any) import Web.Sprinkles.Pattern import Test.Tasty import Test.Tasty.HUnit @@ -175,9 +175,9 @@ parseNamedRegexTest = testCase "parse named Regex" $ do - let src = "/{{who:/foo/}}" + let src = "/{{who:/foo\\./}}" expected = Right $ Pattern - [ PatternPathItem (Just "who") (Regex "foo" RE.compBlank) MatchOne + [ PatternPathItem (Just "who") (Regex "foo\\." RE.compBlank) MatchOne ] [] actual = parsePattern src