diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,12 @@ +* 0.3.0.2 Libby Horacek 2017-6-13 + + - Update base dependencies to support GHC 8 + - Add a stack.yml for 8.15 + +* 0.3.0.1.1 David Hartunian 2017-6-30 + + - Add okJson helper for returning JSON strings as text + * 0.3.0.1 Daniel Patterson 2016-3-11 - Change repository location, copyright. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -5,6 +5,6 @@ ## Example -See the [example application](https://github.com/dbp/fn/tree/master/example) +See the [example application](https://github.com/positiondev/fn/tree/master/example) in the repository for a full usage including database access, heist templates, sessions, etc. diff --git a/fn.cabal b/fn.cabal --- a/fn.cabal +++ b/fn.cabal @@ -1,5 +1,5 @@ name: fn -version: 0.3.0.1 +version: 0.3.0.2 synopsis: A functional web framework. description: A Haskell web framework where you write plain old functions. @@ -82,7 +82,7 @@ library hs-source-dirs: src exposed-modules: Web.Fn - build-depends: base >= 4.7 && < 5 + build-depends: base >= 4.7 && < 6 , wai >= 3 , wai-extra >= 3 , http-types @@ -92,6 +92,7 @@ , unordered-containers , filepath , directory + , resourcet default-language: Haskell2010 ghc-options: -Wall @@ -109,6 +110,7 @@ , unordered-containers , filepath , directory + , resourcet ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall default-language: Haskell2010 diff --git a/src/Web/Fn.hs b/src/Web/Fn.hs --- a/src/Web/Fn.hs +++ b/src/Web/Fn.hs @@ -52,6 +52,7 @@ , staticServe , sendFile , okText + , okJson , okHtml , errText , errHtml @@ -59,12 +60,18 @@ , notFoundHtml , redirect , redirectReferer + -- * Helpers + , tempFileBackEnd' ) where import qualified Blaze.ByteString.Builder.Char.Utf8 as B import Control.Applicative ((<$>)) import Control.Arrow (second) import Control.Concurrent.MVar +import Control.Monad (join) +import Control.Monad.Trans.Resource (InternalState, + closeInternalState, + createInternalState) import Data.ByteString (ByteString) import qualified Data.ByteString.Lazy as LB import Data.Either (lefts, rights) @@ -80,7 +87,9 @@ lbsBackEnd, parseRequestBody) import qualified Network.Wai.Parse as Parse -import System.Directory (doesFileExist) +import System.Directory (doesFileExist, + getTemporaryDirectory, + removeFile) import System.FilePath (takeExtension) data Store b a = Store b (b -> a) @@ -90,7 +99,7 @@ -- | The type of a route, constructed with 'pattern ==> handler'. type Route ctxt = ctxt -> Req -> IO (Maybe (IO (Maybe Response))) -type PostMVar = Maybe (MVar (Maybe ([Param], [Parse.File LB.ByteString]))) +type PostMVar = Maybe (MVar (Maybe (([Param], [Parse.File FilePath]), InternalState))) -- | A normal WAI 'Request' and the parsed post body (if present). We can -- only parse the body once, so we need to have our request (which we @@ -136,7 +145,12 @@ toWAI :: RequestContext ctxt => ctxt -> (ctxt -> IO Response) -> Application toWAI ctxt f req cont = do mv <- newMVar Nothing - f (setRequest ctxt (req, Just mv)) >>= cont + do resp <- f (setRequest ctxt (req, Just mv)) + posted <- tryTakeMVar mv + case join posted of + Nothing -> return () + Just (_,is) -> closeInternalState is + cont resp -- | The main construct for Fn, 'route' takes a context (which it will pass -- to all handlers) and a list of potential matches (which, once they @@ -158,7 +172,7 @@ route ctxt pths = do let (r,post) = getRequest ctxt m = either (const GET) id (parseMethod (requestMethod r)) - req = (filter (/= "") (pathInfo r), queryString r, m, post) + req = (r, filter (/= "") (pathInfo r), queryString r, m, post) route' req pths where route' _ [] = return Nothing route' req (x:xs) = @@ -287,7 +301,7 @@ else return Nothing -- | The parts of the path, when split on /, and the query. -type Req = ([Text], Query, StdMethod, PostMVar) +type Req = (Request, [Text], Query, StdMethod, PostMVar) -- | The non-body parsing connective between route patterns and the -- handler that will be called if the pattern matches. The type is not @@ -304,10 +318,23 @@ do rsp <- match req case rsp of Nothing -> return Nothing - Just ((pathInfo',_,_,_), k) -> + Just ((_,pathInfo',_,_,_), k) -> let (request, mv) = getRequest ctxt in return $ Just (k $ handle (setRequest ctxt (request { pathInfo = pathInfo' }, mv))) +-- | Internal helper - uses the name of the file as the pattern. +tempFileBackEnd' :: InternalState -> ignored1 -> FileInfo () -> IO ByteString -> IO FilePath +tempFileBackEnd' is x fi@(FileInfo nm _ _) = Parse.tempFileBackEndOpts getTemporaryDirectory (T.unpack $ T.decodeUtf8 nm) is x fi + +readBody mv request = + modifyMVar_ mv + (\r -> case r of + Nothing -> + do is <- createInternalState + rb <- parseRequestBody (tempFileBackEnd' is) request + return (Just (rb, is)) + Just _ -> return r) + -- | The connective between route patterns and the handler that parses -- the body, which allows post params to be extracted with 'param' and -- allows 'file' to work (otherwise, it will trigger a runtime error). @@ -319,13 +346,11 @@ IO (Maybe a) (match !=> handle) ctxt req = do let (request, Just mv) = getRequest ctxt - modifyMVar_ mv (\r -> case r of - Nothing -> Just <$> parseRequestBody lbsBackEnd request - Just _ -> return r) + readBody mv request rsp <- match req case rsp of Nothing -> return Nothing - Just ((pathInfo',_,_,_), k) -> + Just ((_,pathInfo',_,_,_), k) -> do return $ Just (k $ handle (setRequest ctxt (request { pathInfo = pathInfo' }, Just mv))) -- | Connects two path segments. Note that when normally used, the @@ -356,7 +381,7 @@ path :: Text -> Req -> IO (Maybe (Req, a -> a)) path s req = return $ case req of - (y:ys,q,m,x) | y == s -> Just ((ys, q, m, x), id) + (r,y:ys,q,m,x) | y == s -> Just ((r,ys, q, m, x), id) _ -> Nothing -- | Matches there being no parts of the path left. This is useful when @@ -364,7 +389,7 @@ end :: Req -> IO (Maybe (Req, a -> a)) end req = return $ case req of - ([],_,_,_) -> Just (req, id) + (_,[],_,_,_) -> Just (req, id) _ -> Nothing -- | Matches anything. @@ -377,14 +402,14 @@ segment :: FromParam p => Req -> IO (Maybe (Req, (p -> a) -> a)) segment req = return $ case req of - (y:ys,q,m,x) -> case fromParam [y] of - Left _ -> Nothing - Right p -> Just ((ys, q, m, x), \k -> k p) + (r,y:ys,q,m,x) -> case fromParam [y] of + Left _ -> Nothing + Right p -> Just ((r, ys, q, m, x), \k -> k p) _ -> Nothing -- | Matches on a particular HTTP method. method :: StdMethod -> Req -> IO (Maybe (Req, a -> a)) -method m r@(_,_,m',_) | m == m' = return $ Just (r, id) +method m r@(_,_,_,m',_) | m == m' = return $ Just (r, id) method _ _ = return Nothing data ParamError = ParamMissing | ParamTooMany | ParamUnparsable | ParamOtherError Text deriving (Eq, Show) @@ -434,7 +459,7 @@ Just mv' -> do v <- readMVar mv' return $ case v of Nothing -> [] - Just (ps',_) -> ps' + Just ((ps',_),_) -> ps' Nothing -> return [] -- | Matches on a query parameter of the given name. It is parsed into @@ -450,7 +475,7 @@ -- match query parameters. param :: FromParam p => Text -> Req -> IO (Maybe (Req, (p -> a) -> a)) param n req = - do let (_,q,_,mv) = req + do let (_,_,q,_,mv) = req ps <- getMVarParams mv return $ case findParamMatches n (q ++ map (second Just) ps) of Right y -> Just (req, \k -> k y) @@ -462,7 +487,7 @@ -- handler, it won't match. paramMany :: FromParam p => Text -> Req -> IO (Maybe (Req, ([p] -> a) -> a)) paramMany n req = - do let (_,q,_,mv) = req + do let (_,_,q,_,mv) = req ps <- getMVarParams mv return $ case findParamMatches n (q ++ map (second Just) ps) of Left _ -> Nothing @@ -482,7 +507,7 @@ Req -> IO (Maybe (Req, (Either ParamError p -> a) -> a)) paramOpt n req = - do let (_,q,_,mv) = req + do let (_,_,q,_,mv) = req ps <- getMVarParams mv return $ Just (req, \k -> k (findParamMatches n (q ++ map (second Just) ps))) @@ -490,50 +515,36 @@ -- | An uploaded file. data File = File { fileName :: Text , fileContentType :: Text - , fileContent :: LB.ByteString + , filePath :: FilePath } -getMVarFiles mv = case mv of - Nothing -> error $ "Fn: tried to read a 'file' or 'files', but FnRequest wasn't initialized with MVar." - Just mv' -> do - v <- readMVar mv' - case v of - Nothing -> error $ "Fn: tried to read a 'file' or 'files' from the request without parsing the body with '!=>'" - Just (_,fs') -> return fs' +getMVarFiles mv req = + case mv of + Nothing -> error $ "Fn: tried to read a 'file' or 'files', but FnRequest wasn't initialized with MVar." + Just mv' -> do + -- NOTE(dbp 2016-03-25): readBody ensures that the value will be Just. + readBody mv' req + Just ((_,fs'),_) <- readMVar mv' + return $ map (\(n, FileInfo nm ct c) -> + (T.decodeUtf8 n, File (T.decodeUtf8 nm) + (T.decodeUtf8 ct) + c)) fs' -- | Matches an uploaded file with the given parameter name. --- --- Note: You must use the '!=>' connective between the pattern and the --- handler, or else the request body will not have been parsed and --- this will fail. file :: Text -> Req -> IO (Maybe (Req, (File -> a) -> a)) file n req = - do let (_,_,_,mv) = req - fs <- getMVarFiles mv - return $ case filter ((== T.encodeUtf8 n) . fst) fs of - [(_, FileInfo nm ct c)] -> Just (req, \k -> k (File (T.decodeUtf8 nm) - (T.decodeUtf8 ct) - c)) + do let (r,_,_,_,mv) = req + fs <- getMVarFiles mv r + return $ case filter ((== n) . fst) fs of + [(_, f)] -> Just (req, \k -> k f) _ -> Nothing -- | Matches all uploaded files, passing their parameter names and -- contents. --- --- Note: You must use the '!=>' connective between the pattern and the --- handler, or else the request body will not have been parsed and --- this will fail. files :: Req -> IO (Maybe (Req, ([(Text, File)] -> a) -> a)) files req = - do let (_,_,_,Just mv) = req - v <- readMVar mv - let fs' = case v of - Nothing -> error $ "Fn: tried to read a 'file' from the request without parsing the body with '!=>'" - Just (_,fs) -> fs - let fs = map (\(n, FileInfo nm ct c) -> - (T.decodeUtf8 n, File (T.decodeUtf8 nm) - (T.decodeUtf8 ct) - c)) - fs' + do let (r,_,_,_,mv) = req + fs <- getMVarFiles mv r return $ Just (req, \k -> k fs) returnText :: Text -> Status -> ByteString -> IO (Maybe Response) @@ -546,6 +557,9 @@ plainText :: ByteString plainText = "text/plain; charset=utf-8" +applicationJson :: ByteString +applicationJson = "application/json; charset=utf-8" + html :: ByteString html = "text/html; charset=utf-8" @@ -553,6 +567,9 @@ okText :: Text -> IO (Maybe Response) okText t = returnText t status200 plainText +-- | Returns 'Text' as a JSON response with appropriate header. +okJson :: Text -> IO (Maybe Response) +okJson j = returnText j status200 applicationJson -- | Returns Html (in 'Text') as a response. okHtml :: Text -> IO (Maybe Response) diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -26,17 +26,17 @@ rr :: R rr = R ([], []) p :: [Text] -> Req -p y = (y,[],GET,Just emv) +p y = (defaultRequest,y,[],GET,Just emv) _p :: [Text] -> Req -> Req -_p y (_,q',m',x') = (y,q',m',x') +_p y (r,_,q',m',x') = (r,y,q',m',x') q :: Query -> Req -q y = ([],y,GET,Just emv) +q y = (defaultRequest,[],y,GET,Just emv) _q :: Query -> Req -> Req -_q y (p',_,m',x') = (p',y,m',x') +_q y (r,p',_,m',x') = (r,p',y,m',x') m :: StdMethod -> Req -m y = ([],[],y,Just emv) +m y = (defaultRequest,[],[],y,Just emv) _m :: StdMethod -> Req -> Req -_m y (p',q',_,x') = (p',q',y,x') +_m y (r,p',q',_,x') = (r,p',q',y,x') j :: Show a => IO (Maybe (a,b)) -> Expectation @@ -160,6 +160,12 @@ it "should match nested routes" $ do r <- route (R (["a", "b"], [])) [path "a" ==> (\c -> route c [path "b" ==> const (okText "")])] (responseStatus <$> r) `shouldSatisfy` isJust + + describe "okJson" $ do + it "should have Content-Type: applcation/json as a header" $ + do maybeResponse <- okJson "{'key': 'value'}" + let headers = responseHeaders $ fromJust maybeResponse + headers `shouldBe` [(hContentType, "application/json; charset=utf-8")] describe "parameter parsing" $ do it "should parse Text" $