servant-auth-cookie 0.3.3.1 → 0.4
raw patch · 4 files changed
+136/−48 lines, 4 filesdep +base-compatdep +bytestring-conversiondep +http-api-datadep ~cryptonitedep ~memorydep ~servant
Dependencies added: base-compat, bytestring-conversion, http-api-data
Dependency ranges changed: cryptonite, memory, servant, servant-blaze, servant-server, time
Files
- example/Main.hs +27/−8
- servant-auth-cookie.cabal +43/−18
- src/Servant/Server/Experimental/Auth/Cookie.hs +65/−21
- tests/Main.hs +1/−1
example/Main.hs view
@@ -9,30 +9,35 @@ module Main (main) where +import Prelude ()+import Prelude.Compat+ import Control.Monad import Crypto.Random (drgNew)-import Data.ByteString (ByteString) import Data.Default import Data.List (find) import Data.Serialize (Serialize) import GHC.Generics import Network.Wai (Application, Request) import Network.Wai.Handler.Warp (run)-import Servant (FromFormUrlEncoded(..), FormUrlEncoded, (:<|>)(..), (:>), ReqBody)+#if MIN_VERSION_servant (0,9,0)+import Web.FormUrlEncoded (FromForm(..), lookupUnique)+#else+import Servant (FromFormUrlEncoded(..))+#endif+import Servant ((:<|>)(..), (:>), ReqBody, FormUrlEncoded) import Servant (Post, Headers, Header, AuthProtect, Get, Server, Proxy) import Servant (addHeader, serveWithContext, Proxy(..), Context(..)) import Servant.HTML.Blaze import Servant.Server.Experimental.Auth (AuthHandler) import Servant.Server.Experimental.Auth.Cookie import Text.Blaze.Html5 ((!), Markup)+import System.Exit (exitSuccess)+import System.Environment (getArgs) import qualified Data.Text as T import qualified Text.Blaze.Html5 as H import qualified Text.Blaze.Html5.Attributes as A -#if !MIN_VERSION_base(4,8,0)-import Control.Applicative-#endif- data Account = Account { accUid :: Int , _accUsername :: String@@ -48,6 +53,15 @@ , lfPassword :: String } deriving (Eq, Show) +#if MIN_VERSION_servant (0,9,0)+instance FromForm LoginForm where+ fromForm f = do+ username <- fmap T.unpack $ lookupUnique "username" f+ password <- fmap T.unpack $ lookupUnique "password" f+ return LoginForm+ { lfUsername = username+ , lfPassword = password }+#else instance FromFormUrlEncoded LoginForm where fromFormUrlEncoded d = do username <- case lookup "username" d of@@ -59,6 +73,7 @@ return LoginForm { lfUsername = username , lfPassword = password }+#endif usersDB :: [Account] usersDB =@@ -74,7 +89,7 @@ Get '[HTML] Markup :<|> "login" :> Get '[HTML] Markup :<|> "login" :> ReqBody '[FormUrlEncoded] LoginForm- :> Post '[HTML] (Headers '[Header "set-cookie" ByteString] Markup)+ :> Post '[HTML] (Headers '[Header "set-cookie" EncryptedSession] Markup) :<|> "private" :> AuthProtect "cookie-auth" :> Get '[HTML] Markup server :: AuthCookieSettings -> RandomSource -> ServerKey -> Server ExampleAPI@@ -88,7 +103,7 @@ serveLoginPost LoginForm {..} = case userLookup lfUsername lfPassword usersDB of- Nothing -> return $ addHeader "" (loginPage False)+ Nothing -> return $ addHeader emptyEncryptedSession (loginPage False) Just uid -> addSession settings -- the settings rs -- random source@@ -106,6 +121,10 @@ main :: IO () main = do+ args <- getArgs+ when (args /= ["run"]) $ do+ putStrLn "Use './example run' to run an example"+ exitSuccess rs <- mkRandomSource drgNew 1000 sk <- mkServerKey 16 Nothing run 8080 (app def rs sk)
servant-auth-cookie.cabal view
@@ -1,5 +1,5 @@ name: servant-auth-cookie-version: 0.3.3.1+version: 0.4 synopsis: Authentication via encrypted cookies description: Authentication via encrypted client-side cookies, inspired by client-session library by Michael Snoyman and based on@@ -22,6 +22,11 @@ manual: True default: False +flag servant9+ description: Use servant-0.9+ manual: False+ default: True+ library exposed-modules: Servant.Server.Experimental.Auth.Cookie@@ -32,19 +37,19 @@ , bytestring , cereal >= 0.5 && < 0.6 , cookie >= 0.4.1 && < 0.5- , cryptonite >= 0.14 && <= 0.21+ , cryptonite >= 0.14 && <= 0.20 , data-default , exceptions >= 0.8 && < 0.9 , http-types >= 0.9 && < 0.10- , memory >= 0.11 && <= 0.14.1+ , memory >= 0.11 && < 0.14 , mtl >= 2.0 && < 3.0- , servant >= 0.5 && < 0.9- , servant-server >= 0.5 && < 0.9- , time >= 1.5 && <= 1.7.0.1+ , servant >= 0.5 && < 0.10+ , servant-server >= 0.5 && < 0.10+ , tagged == 0.8.*+ , time >= 1.5 && < 1.7 , transformers >= 0.4 && < 0.6 , wai >= 3.0 && < 3.3- if !impl(ghc >= 7.8)- build-depends: tagged == 0.8.*+ if flag(dev) ghc-options: -Wall -Werror else@@ -52,21 +57,32 @@ hs-source-dirs: src default-language: Haskell2010 -executable example+ if flag(servant9)+ build-depends:+ servant >= 0.9,+ http-api-data == 0.3.*+ else+ build-depends:+ servant < 0.9,+ bytestring-conversion >= 0.3.1 && <0.4++test-suite example+ type: exitcode-stdio-1.0 main-is: Main.hs build-depends: base >= 4.7 && < 5.0+ , base-compat >= 0.9.1 && <0.10 , blaze-html >= 0.8 && < 0.9 , blaze-markup >= 0.7 && < 0.8 , bytestring , cereal >= 0.5 && < 0.6- , cryptonite >= 0.14 && <= 0.21+ , cryptonite >= 0.14 && <= 0.20 , data-default , http-media , mtl >= 2.0 && < 3.0- , servant >= 0.5 && < 0.9+ , servant >= 0.5 && < 0.10 , servant-auth-cookie- , servant-blaze >= 0.5 && < 0.9- , servant-server >= 0.5 && < 0.9+ , servant-blaze >= 0.5 && < 0.10+ , servant-server >= 0.5 && < 0.10 , text , wai >= 3.0 && < 3.3 , warp >= 3.0 && < 3.3@@ -77,6 +93,15 @@ hs-source-dirs: example default-language: Haskell2010 + if flag(servant9)+ build-depends:+ servant >= 0.9,+ http-api-data == 0.3.*+ else+ build-depends:+ servant < 0.9,+ bytestring-conversion >= 0.3.1 && <0.4+ test-suite tests type: exitcode-stdio-1.0 hs-source-dirs: tests@@ -90,13 +115,13 @@ , QuickCheck >= 2.4 && < 3.0 , bytestring , cereal >= 0.5 && < 0.6- , cryptonite >= 0.14 && <= 0.21+ , cryptonite >= 0.14 && <= 0.20 , data-default , deepseq >= 1.3 && < 1.5 , hspec >= 2.0 && < 3.0 , servant-auth-cookie- , servant-server >= 0.5 && < 0.9- , time >= 1.5 && <= 1.7.0.1+ , servant-server >= 0.5 && < 0.10+ , time >= 1.5 && < 1.7 if !impl(ghc >= 7.8) build-depends: tagged == 0.8.* default-language: Haskell2010@@ -112,9 +137,9 @@ build-depends: base >= 4.7 && < 5.0 , bytestring , criterion >= 0.6.2.1 && < 1.2- , cryptonite >= 0.14 && <= 0.21+ , cryptonite >= 0.14 && <= 0.20 , servant-auth-cookie- , servant-server >= 0.5 && < 0.9+ , servant-server >= 0.5 && < 0.10 if flag(dev) ghc-options: -Wall -Werror else
src/Servant/Server/Experimental/Auth/Cookie.hs view
@@ -41,6 +41,9 @@ , AuthCookieSettings (..) + , EncryptedSession (..)+ , emptyEncryptedSession+ , encryptCookie , decryptCookie @@ -50,10 +53,10 @@ , addSession , addSessionToErr , getSession- + -- exposed for testing purpose , renderSession- + , defaultAuthHandler ) where @@ -76,6 +79,7 @@ import Data.Proxy import Data.Serialize import Data.Time+import Data.Tagged (Tagged (..), retag) import Data.Typeable import GHC.TypeLits (Symbol) import Network.HTTP.Types (hCookie)@@ -96,6 +100,12 @@ import Control.Applicative #endif +#if MIN_VERSION_servant(0,9,0)+import Servant (ToHttpApiData (..))+#else+import Data.ByteString.Conversion (ToByteString (..))+#endif+ ---------------------------------------------------------------------------- -- General types @@ -113,6 +123,23 @@ , cookiePayload :: ByteString -- ^ The payload } deriving (Eq, Show) +-- | A newtype wrapper over 'ByteString'+newtype EncryptedSession = EncryptedSession ByteString+ deriving (Eq, Show, Typeable)++-- | An empty 'EncryptedSession'+emptyEncryptedSession :: EncryptedSession+emptyEncryptedSession = EncryptedSession ""++#if MIN_VERSION_servant(0,9,0)+instance ToHttpApiData EncryptedSession where+ toHeader (EncryptedSession s) = s+ toUrlPiece = error "toUrlPiece @EncryptedSession: not implemented"+#else+instance ToByteString EncryptedSession where+ builder (EncryptedSession s) = builder s+#endif+ -- | The exception is thrown when something goes wrong with this package. data AuthCookieException@@ -137,6 +164,23 @@ instance Exception AuthCookieException ----------------------------------------------------------------------------+-- Tags for various bytestrings++-- | Tag encrypted cookie+data EncryptedCookie++-- | Tag for base64 serialized and encrypted cookie+data SerializedEncryptedCookie++base64Encode :: Tagged EncryptedCookie ByteString -> Tagged SerializedEncryptedCookie ByteString+base64Encode = retag . fmap Base64.encode++base64Decode+ :: Tagged SerializedEncryptedCookie ByteString+ -> Either String (Tagged EncryptedCookie ByteString)+base64Decode = fmap Tagged . Base64.decode . unTagged++---------------------------------------------------------------------------- -- Random source -- | A wrapper of self-resetting 'DRG' suitable for concurrent usage.@@ -186,7 +230,7 @@ => ByteString -- ^ Predefined key -> m ServerKey -- ^ New 'ServerKey' mkServerKeyFromBytes bytes =- ServerKey (BS.length bytes) Nothing `liftM` liftIO (newIORef (bytes, timeOrigin)) + ServerKey (BS.length bytes) Nothing `liftM` liftIO (newIORef (bytes, timeOrigin)) where -- we don't care about the time as the key never expires timeOrigin = UTCTime (toEnum 0) 0@@ -273,7 +317,7 @@ => AuthCookieSettings -- ^ Options, see 'AuthCookieSettings' -> ServerKey -- ^ 'ServerKey' to use -> Cookie -- ^ The 'Cookie' to encrypt- -> m ByteString -- ^ Encrypted 'Cookie' is form of 'ByteString'+ -> m (Tagged EncryptedCookie ByteString) -- ^ Encrypted 'Cookie' is form of 'ByteString' encryptCookie AuthCookieSettings {..} sk cookie = do let iv = cookieIV cookie expiration = BSC8.pack $ formatTime@@ -288,7 +332,7 @@ iv key (cookiePayload cookie) let mac = sign acsHashAlgorithm serverKey (BS.concat [iv, expiration, payload])- return . runPut $ do+ return . Tagged . runPut $ do putByteString iv putByteString expiration putByteString payload@@ -306,11 +350,11 @@ -- * 'CannotParseExpirationTime' -- * 'CookieExpired' decryptCookie :: (MonadIO m, MonadThrow m)- => AuthCookieSettings -- ^ Options, see 'AuthCookieSettings'- -> ServerKey -- ^ 'ServerKey' to use- -> ByteString -- ^ The 'ByteString' to decrypt- -> m Cookie -- ^ The decrypted 'Cookie'-decryptCookie AuthCookieSettings {..} sk s = do+ => AuthCookieSettings -- ^ Options, see 'AuthCookieSettings'+ -> ServerKey -- ^ 'ServerKey' to use+ -> Tagged EncryptedCookie ByteString -- ^ The 'ByteString' to decrypt+ -> m Cookie -- ^ The decrypted 'Cookie'+decryptCookie AuthCookieSettings {..} sk (Tagged s) = do currentTime <- liftIO getCurrentTime let ivSize = blockSize (unProxy acsCipher) expSize =@@ -349,7 +393,7 @@ -> RandomSource -- ^ Random source to use -> ServerKey -- ^ 'ServerKey' to use -> a -- ^ Session value- -> m ByteString -- ^ Serialized and encrypted session+ -> m (Tagged SerializedEncryptedCookie ByteString) -- ^ Serialized and encrypted session encryptSession acs@AuthCookieSettings {..} randomSource sk session = do iv <- getRandomBytes randomSource (blockSize $ unProxy acsCipher) expirationTime <- liftM (addUTCTime acsMaxAge) (liftIO getCurrentTime)@@ -359,7 +403,7 @@ n = BS.length payload l = (bs - (n `rem` bs)) `rem` bs in getRandomBytes randomSource l- Base64.encode `liftM` encryptCookie acs sk (Cookie+ base64Encode `liftM` encryptCookie acs sk (Cookie { cookieIV = iv , cookieExpirationTime = expirationTime , cookiePayload = BS.concat [payload, padding] })@@ -367,13 +411,13 @@ -- | Unpack session value from a cookie. The function can throw the same -- exceptions as 'decryptCookie'. decryptSession :: (MonadIO m, MonadThrow m, Serialize a)- => AuthCookieSettings -- ^ Options, see 'AuthCookieSettings'- -> ServerKey -- ^ 'ServerKey' to use- -> ByteString -- ^ Cookie in binary form- -> m a -- ^ Unpacked session value+ => AuthCookieSettings -- ^ Options, see 'AuthCookieSettings'+ -> ServerKey -- ^ 'ServerKey' to use+ -> Tagged SerializedEncryptedCookie ByteString -- ^ Cookie in binary form+ -> m a -- ^ Unpacked session value decryptSession acs@AuthCookieSettings {..} sk s = let fromRight = either (throwM . SessionDeserializationFailed) return- in fromRight (Base64.decode s) >>=+ in fromRight (base64Decode s) >>= decryptCookie acs sk >>= fromRight . runGet get . cookiePayload @@ -386,7 +430,7 @@ :: ( MonadIO m , MonadThrow m , Serialize a- , AddHeader (e :: Symbol) ByteString s r )+ , AddHeader (e :: Symbol) EncryptedSession s r ) => AuthCookieSettings -- ^ Options, see 'AuthCookieSettings' -> RandomSource -- ^ Random source to use -> ServerKey -- ^ 'ServerKey' to use@@ -395,7 +439,7 @@ -> m r -- ^ Response with the session added addSession acs rs sk sessionData response = do header <- renderSession acs rs sk sessionData- return (addHeader header response)+ return (addHeader (EncryptedSession header) response) -- | Add cookie session to error allowing to set cookie even if response is -- not 200.@@ -425,7 +469,7 @@ getSession acs@AuthCookieSettings {..} sk request = do let cookies = parseCookies <$> lookup hCookie (requestHeaders request) sessionBinary = cookies >>= lookup acsSessionField- maybe (return Nothing) (liftM Just . decryptSession acs sk) sessionBinary+ maybe (return Nothing) (liftM Just . decryptSession acs sk . Tagged) sessionBinary -- | Render session cookie to 'ByteString'. renderSession@@ -438,7 +482,7 @@ -> a -> m ByteString renderSession acs@AuthCookieSettings {..} rs sk sessionData = do- sessionBinary <- encryptSession acs rs sk sessionData+ Tagged sessionBinary <- encryptSession acs rs sk sessionData let cookies = (acsSessionField, sessionBinary) : ("Path", acsPath) :
tests/Main.hs view
@@ -188,7 +188,7 @@ , acsHashAlgorithm = h , acsCipher = c , .. }- encryptCookie sts sk cookie >>= decryptCookie sts sk . encryptionHook+ encryptCookie sts sk cookie >>= decryptCookie sts sk . fmap encryptionHook sessionSpec :: Spec sessionSpec = do