summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorLibbyHoracek <>2017-09-13 00:23:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2017-09-13 00:23:00 (GMT)
commit494f8dbd30de8259caa2586a672cef1dbd903cb5 (patch)
treee8e42ea71ab6d5da504e7df17d01fc344dfe8215
parent9682bbc249a06b6f57b8b0f4ac417b9ddb79eda4 (diff)
version 0.3.0.2HEAD0.3.0.2master
-rw-r--r--CHANGELOG.md9
-rw-r--r--README.md2
-rw-r--r--fn.cabal6
-rw-r--r--src/Web/Fn.hs121
-rw-r--r--test/Spec.hs18
5 files changed, 95 insertions, 61 deletions
diff --git a/CHANGELOG.md b/CHANGELOG.md
index 8f3c19b..422b3ee 100644
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -1,3 +1,12 @@
+* 0.3.0.2 Libby Horacek <libby@positiondev.com> 2017-6-13
+
+ - Update base dependencies to support GHC 8
+ - Add a stack.yml for 8.15
+
+* 0.3.0.1.1 David Hartunian <david@positiondev.com> 2017-6-30
+
+ - Add okJson helper for returning JSON strings as text
+
* 0.3.0.1 Daniel Patterson <dbp@dbpmail.net> 2016-3-11
- Change repository location, copyright.
diff --git a/README.md b/README.md
index ca2513e..915e321 100644
--- 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
index f465b26..95959bf 100644
--- 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 @@ cabal-version: >=1.10
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 @@ library
, unordered-containers
, filepath
, directory
+ , resourcet
default-language: Haskell2010
ghc-options: -Wall
@@ -109,6 +110,7 @@ test-suite fn-test
, 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
index db3a84f..6b5ba7d 100644
--- a/src/Web/Fn.hs
+++ b/src/Web/Fn.hs
@@ -52,6 +52,7 @@ module Web.Fn ( -- * Application setup
, staticServe
, sendFile
, okText
+ , okJson
, okHtml
, errText
, errHtml
@@ -59,12 +60,18 @@ module Web.Fn ( -- * Application setup
, 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 @@ import Network.Wai.Parse (FileInfo (..), Param,
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 @@ instance Functor (Store b) where
-- | 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 @@ instance RequestContext FnRequest where
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 :: RequestContext ctxt =>
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 @@ sendFile pth =
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 @@ type Req = ([Text], Query, StdMethod, PostMVar)
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 @@ type Req = ([Text], Query, StdMethod, PostMVar)
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 @@ type Req = ([Text], Query, StdMethod, PostMVar)
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 @@ path s req =
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 @@ anything req = return $ Just (req, id)
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 @@ getMVarParams mv = case mv of
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 @@ getMVarParams mv = case mv of
-- 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 @@ param n req =
-- 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 @@ paramOpt :: FromParam p =>
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 @@ paramOpt n req =
-- | 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 @@ returnText text status content =
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 @@ html = "text/html; charset=utf-8"
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
index 47367df..ce55a63 100644
--- a/test/Spec.hs
+++ b/test/Spec.hs
@@ -26,17 +26,17 @@ instance RequestContext R where
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
@@ -161,6 +161,12 @@ main = hspec $ do
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" $
fromParam ["hello"] `shouldBe` Right ("hello" :: Text)