diff --git a/example/Main.hs b/example/Main.hs --- a/example/Main.hs +++ b/example/Main.hs @@ -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) diff --git a/servant-auth-cookie.cabal b/servant-auth-cookie.cabal --- a/servant-auth-cookie.cabal +++ b/servant-auth-cookie.cabal @@ -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 diff --git a/src/Servant/Server/Experimental/Auth/Cookie.hs b/src/Servant/Server/Experimental/Auth/Cookie.hs --- a/src/Servant/Server/Experimental/Auth/Cookie.hs +++ b/src/Servant/Server/Experimental/Auth/Cookie.hs @@ -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) : diff --git a/tests/Main.hs b/tests/Main.hs --- a/tests/Main.hs +++ b/tests/Main.hs @@ -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