diff --git a/hikaru.cabal b/hikaru.cabal index af1b8df83e0fab21fced90a661ac99c0069872db..7b196e05426a8799ee438f8628e8a11260745535 100644 --- a/hikaru.cabal +++ b/hikaru.cabal @@ -2,7 +2,7 @@ -- -- see: https://github.com/sol/hpack -- --- hash: 73104125e4378c6f6439e76e1ce707e88a84d9aa8a01b85bd279a636e97f94ca +-- hash: da893a0d06b5067ae693df0f78119bcf5c7a0742b3916c78df7e91e555477f18 name: hikaru version: 0.1.0.0 @@ -53,6 +53,7 @@ library , bytestring >=0.10 && <0.11 , case-insensitive >=1.2 && <1.3 , containers >=0.6 && <0.7 + , cookie >=0.4 && <0.5 , http-types >=0.12 && <0.13 , lucid >=2.9 && <2.10 , mtl >=2.2 && <2.3 diff --git a/lib/Web/Hikaru/Action.hs b/lib/Web/Hikaru/Action.hs index 9d28eb07ae83cd6f634bebd2d6316e3af3e23211..8d5cd23a5ffb85fcfdddf0731baa548dcb08fdb6 100644 --- a/lib/Web/Hikaru/Action.hs +++ b/lib/Web/Hikaru/Action.hs @@ -30,6 +30,9 @@ module Web.Hikaru.Action , getParamMaybe , getParamList , getParamDefault + , getCookies + , getCookieMaybe + , getCookieDefault , getBodyLength , setBodyLimit , getBodyLimit @@ -53,6 +56,8 @@ module Web.Hikaru.Action , addHeader , defaultHeader , modifyHeader + , setCookie + , setCookieEx , sendHTML , sendText , sendString @@ -98,6 +103,7 @@ where import Network.Wai import Network.Wai.Internal (getRequestBodyChunk) import Network.Wai.Parse + import Web.Cookie import Web.Hikaru.Media import Web.Hikaru.Types @@ -340,7 +346,7 @@ where -- | -- Similar to 'getParamMaybe', but return either the parsed parameter - -- or a specified default value. + -- or the specified default value. -- getParamDefault :: (MonadAction m, FromParam a) => Text -> a -> m a getParamDefault n v = fromMaybe v <$> getParamMaybe n @@ -356,6 +362,36 @@ where <$> getParams + -- | + -- Obtain all request cookies. + -- + getCookies :: (MonadAction m) => m [(Text, Text)] + getCookies = do + mc <- getHeaderMaybe hCookie + + case mc of + Nothing -> return [] + Just bs -> return $ map cs2 $ parseCookies bs + + + -- | + -- Obtain a specific cookie and parse it on the fly to the target type. + -- Parsing failure maps to 'Nothing'. + -- + getCookieMaybe :: (MonadAction m, FromParam a) => Text -> m (Maybe a) + getCookieMaybe n = lookup n <$> getCookies + >>= \case Nothing -> return $ Nothing + Just val -> return $ fromParam val + + + -- | + -- Similar to 'getCookieMaybe', but return either the parsed cookie + -- or the specified default value. + -- + getCookieDefault :: (MonadAction m, FromParam a) => Text -> a -> m a + getCookieDefault n v = fromMaybe v <$> getCookieMaybe n + + -- | -- Try to obtain request body length. -- This will fail when the body is chunked. @@ -536,8 +572,7 @@ where -- Use 'setBodyLimit' to adjust the limit to your liking. -- getFields :: (MonadAction m) => m [(Text, Text)] - getFields = map convert <$> fst <$> getForm - where convert (n, v) = (cs n, cs v) + getFields = map cs2 <$> fst <$> getForm -- | @@ -552,7 +587,7 @@ where -- | -- Similar to 'getFieldMaybe', but return either the parsed field - -- or a specified default value. + -- or the specified default value. -- getFieldDefault :: (MonadAction m, FromParam a) => Text -> a -> m a getFieldDefault n v = fromMaybe v <$> getFieldMaybe n @@ -639,10 +674,7 @@ where -- csForm :: ([Param], [File FilePath]) -> ([(Text, Text)], [(Text, FileInfo FilePath)]) - csForm (ps, fs) = (ps', fs') - where - ps' = map (\(n, v) -> (cs n, cs v)) ps - fs' = map (\(n, f) -> (cs n, f)) fs + csForm (ps, fs) = (map cs2 ps, map cs1 fs) -- | @@ -744,6 +776,32 @@ where where v' = fn (lookup n hs) + -- | + -- Set a cookie with just a name and a value. + -- + -- Such cookies are valid for the whole domain, expire when the browser + -- is closed, can be accessed from JavaScript and may be sent with + -- cross-site requests. + -- + -- Do not use cookies set in this way for anything else than storing + -- simple user preferences. + -- + setCookie :: (MonadAction m) => ByteString -> ByteString -> m () + setCookie name value = do + setCookieEx $ defaultSetCookie { setCookieName = name + , setCookieValue = value + , setCookiePath = Just "/" + } + + + -- | + -- Set a cookie using the 'Web.Cookie.SetCookie' directly. + -- + setCookieEx :: (MonadAction m) => SetCookie -> m () + setCookieEx cookie = do + addHeader hSetCookie $ cs $ toLazyByteString $ renderSetCookie cookie + + -- | -- Default @Content-Type@ to @text/html; charset=utf8@ -- and set the response body to the provided byte string. @@ -893,4 +951,21 @@ where headerEq (x, _) (y, _) = x == y + -- | + -- Helper to apply 'cs' to both elements of a 2-tuple. + -- + cs2 :: ( ConvertibleStrings a c + , ConvertibleStrings b d + ) + => (a, b) -> (c, d) + cs2 (x, y) = (cs x, cs y) + + + -- | + -- Helper to apply 'cs' to the first element of a 2-tuple. + -- + cs1 :: (ConvertibleStrings a c) => (a, b) -> (c, b) + cs1 (x, y) = (cs x, y) + + -- vim:set ft=haskell sw=2 ts=2 et: diff --git a/package.yaml b/package.yaml index 17b80542c490b5cb8573e262bab088e9dbcb56fc..274cc765a9584b28f59d6a250facbd0cd3bb5b49 100644 --- a/package.yaml +++ b/package.yaml @@ -45,6 +45,7 @@ dependencies: - bytestring >= 0.10 && <0.11 - case-insensitive >= 1.2 && <1.3 - containers >= 0.6 && <0.7 + - cookie >= 0.4 && <0.5 - http-types >= 0.12 && <0.13 - lucid >= 2.9 && <2.10 - mtl >= 2.2 && <2.3