fn 0.3.0.1 → 0.3.0.2

raw patch · 5 files changed

+95/−61 lines, 5 filesdep +resourcetdep ~basenew-uploaderPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: resourcet

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• CHANGELOG.md +9/−0
• README.md +1/−1
• fn.cabal +4/−2
• src/Web/Fn.hs +69/−52
• test/Spec.hs +12/−6

@@ -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.

@@ -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.

@@ -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 

@@ -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)

@@ -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" $