diff --git a/src/Yesod/Auth/DeskCom.hs b/src/Yesod/Auth/DeskCom.hs --- a/src/Yesod/Auth/DeskCom.hs +++ b/src/Yesod/Auth/DeskCom.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} module Yesod.Auth.DeskCom ( YesodDeskCom(..) , deskComCreateCreds @@ -6,17 +7,16 @@ , DeskComUserId(..) , DeskComCustomField , DeskCom - , getDeskCom + , initDeskCom , deskComLoginRoute , deskComMaybeLoginRoute ) where import Control.Applicative ((<$>)) -import Control.Monad.IO.Class (MonadIO, liftIO) +import Crypto.Hash.CryptoAPI (SHA1) import Data.Default (Default(..)) import Data.Monoid ((<>)) import Data.Text (Text) -import Language.Haskell.TH.Syntax (Pred(ClassP), Type(VarT), mkName) import Network.HTTP.Types (renderSimpleQuery) import Yesod.Auth import Yesod.Core @@ -25,21 +25,23 @@ import qualified Crypto.Hash.SHA1 as SHA1 import qualified Crypto.HMAC as HMAC import qualified Crypto.Padding as Padding +import qualified Crypto.Random.AESCtr as CPRNG import qualified Data.Aeson as A import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Base64 as B64 import qualified Data.ByteString.Base64.URL as B64URL +import qualified Data.IORef as I import qualified Data.Text as T import qualified Data.Text.Encoding as TE import qualified Data.Time as TI - +import Yesod.Auth.DeskCom.Data -- | Type class that you need to implement in order to support -- Desk.com remote authentication. -- -- /Minimal complete definition:/ everything except for 'deskComTokenTimeout'. -class YesodAuth master => YesodDeskCom master where +class YesodAuthPersist master => YesodDeskCom master where -- | The credentials needed to use Multipass. Use -- 'deskComCreateCreds'. We recommend caching the resulting -- 'DeskComCredentials' value on your foundation data type @@ -79,7 +81,7 @@ -- 'maybeAuth' instead of 'requireAuth' and login on Desk.com -- with some sort of guest user should the user not be logged -- in. - deskComUserInfo :: AuthId master -> GHandler DeskCom master DeskComUser + deskComUserInfo :: AuthId master -> HandlerT master IO DeskComUser -- | Each time we login an user on Desk.com, we create a token. -- This function defines how much time the token should be @@ -88,6 +90,8 @@ deskComTokenTimeout :: master -> TI.NominalDiffTime deskComTokenTimeout _ = 300 -- seconds +instance YesodDeskCom master => YesodSubDispatch DeskCom (HandlerT master IO) where + yesodSubDispatch = $(mkYesodSubDispatch resourcesDeskCom) -- | Create the credentials data type used by this library. This -- function is relatively expensive (uses SHA1 and AES), so @@ -104,7 +108,7 @@ where -- Yes, I know, Desk.com's crypto is messy. aesKey = AES.initKey . B.take 16 . SHA1.hash . TE.encodeUtf8 $ apiKey <> site - hmacKey = HMAC.MacKey $ TE.encodeUtf8 apiKey + hmacKey = TE.encodeUtf8 apiKey -- | Credentials used to access your Desk.com's Multipass. @@ -113,7 +117,7 @@ { dccSite :: !T.Text , dccDomain :: !T.Text , dccAesKey :: !AES.Key - , dccHmacKey :: !(HMAC.MacKey SHA1.Ctx SHA1.SHA1) + , dccHmacKey :: !B.ByteString -- HMAC.MacKey ?????? SHA1 } @@ -177,23 +181,6 @@ ---------------------------------------------------------------------- --- | Data type for @yesod-auth-deskCom@\'s subsite. -data DeskCom = DeskCom - - --- | Create a new 'DeskCom', use this on your @config/routes@ file. -getDeskCom :: a -> DeskCom -getDeskCom = const DeskCom - - -mkYesodSub "DeskCom" - [ClassP ''YesodDeskCom [VarT $ mkName "master"]] - [parseRoutes| - / DeskComLoginR GET - /m DeskComMaybeLoginR GET -|] - - -- | Redirect the user to Desk.com such that they're already -- logged in when they arrive. For example, you may use -- @deskComLoginRoute@ as the login URL on Multipass config. @@ -210,45 +197,51 @@ deskComMaybeLoginRoute :: Route DeskCom deskComMaybeLoginRoute = DeskComMaybeLoginR - -- | Route used by the Desk.com remote authentication. Works -- both when Desk.com call us and when we call them. Forces user -- to be logged in. -getDeskComLoginR :: YesodDeskCom master => GHandler DeskCom master () -getDeskComLoginR = requireAuthId >>= redirectToMultipass +getDeskComLoginR :: YesodDeskCom master + => HandlerT DeskCom (HandlerT master IO) () +getDeskComLoginR = lift requireAuthId >>= redirectToMultipass -- | Same as 'getDeskComLoginR' if the user is logged in, -- otherwise redirect to the Desk.com portal without asking for -- credentials. -getDeskComMaybeLoginR :: YesodDeskCom master => GHandler DeskCom master () -getDeskComMaybeLoginR = maybeAuthId >>= maybe redirectToPortal redirectToMultipass +getDeskComMaybeLoginR :: YesodDeskCom master + => HandlerT DeskCom (HandlerT master IO) () +getDeskComMaybeLoginR = lift maybeAuthId >>= maybe redirectToPortal redirectToMultipass -- | Redirect the user to the main Desk.com portal. -redirectToPortal :: YesodDeskCom master => GHandler DeskCom master () +redirectToPortal :: YesodDeskCom master => HandlerT DeskCom (HandlerT master IO) () redirectToPortal = do - y <- getYesod + y <- lift getYesod let DeskComCredentials {..} = deskComCredentials y redirect $ T.concat [ "http://", dccDomain, "/" ] -- | Redirect the user to the multipass login. -redirectToMultipass :: YesodDeskCom master => AuthId master -> GHandler DeskCom master () +redirectToMultipass :: YesodDeskCom master + => AuthId master + -> HandlerT DeskCom (HandlerT master IO) () redirectToMultipass uid = do -- Get generic info. - y <- getYesod + y <- lift getYesod let DeskComCredentials {..} = deskComCredentials y -- Get the expires timestamp. expires <- TI.addUTCTime (deskComTokenTimeout y) <$> liftIO TI.getCurrentTime -- Get information about the currently logged user. - DeskComUser {..} <- deskComUserInfo uid + DeskComUser {..} <- lift (deskComUserInfo uid) userId <- case duUserId of - UseYesodAuthId -> toPathPiece <$> requireAuthId + UseYesodAuthId -> toPathPiece <$> lift requireAuthId Explicit x -> return x + -- Generate an IV. + iv@(AES.IV ivBS) <- deskComRandomIV + -- Create Multipass token. let toStrict = B.concat . BL.toChunks deskComEncode @@ -256,12 +249,15 @@ . B64URL.encode -- base64url encoding encrypt = deskComEncode -- encode as modified base64url - . AES.encryptCBC dccAesKey blankIV -- encrypt with AES128-CBC + . AES.encryptCBC dccAesKey iv -- encrypt with AES128-CBC + . (ivBS <>) -- prepend the IV . Padding.padPKCS5 16 -- PKCS#5 padding . toStrict . A.encode . A.object -- encode as JSON sign = B64.encode . Crypto.encode -- encode as normal base64 (why??? =[) - . HMAC.hmac' dccHmacKey -- sign using HMAC-SHA1 + . HMAC.hmac' hmacKey -- sign using HMAC-SHA1 + hmacKey :: HMAC.MacKey ctx SHA1 + hmacKey = HMAC.MacKey dccHmacKey multipass = encrypt $ "uid" A..= userId : "expires" A..= expires : @@ -280,7 +276,10 @@ ] --- | A blank IV consisting of NUL bytes. Yes, Desk.com's messy --- crypto avoids using IVs! -blankIV :: AES.IV -blankIV = AES.IV (B.replicate 16 0) +-- | Randomly generate an IV. +deskComRandomIV :: HandlerT DeskCom (HandlerT master IO) AES.IV +deskComRandomIV = do + var <- deskComCprngVar <$> getYesod + liftIO $ I.atomicModifyIORef var $ + \g -> let (bs, g') = CPRNG.genRandomBytes 16 g + in (g', g' `seq` AES.IV bs) diff --git a/src/Yesod/Auth/DeskCom/Data.hs b/src/Yesod/Auth/DeskCom/Data.hs new file mode 100644 --- /dev/null +++ b/src/Yesod/Auth/DeskCom/Data.hs @@ -0,0 +1,20 @@ +module Yesod.Auth.DeskCom.Data where + +import Control.Applicative ((<$>)) +import Yesod.Core +import qualified Crypto.Random.AESCtr as CPRNG +import qualified Data.IORef as I + +-- | Data type for @yesod-auth-deskCom@\'s subsite. +data DeskCom = DeskCom { deskComCprngVar :: I.IORef CPRNG.AESRNG } + + +-- | Initialize the 'DeskCom' subsite with a fresh CPRNG. +initDeskCom :: IO DeskCom +initDeskCom = DeskCom <$> (I.newIORef =<< CPRNG.makeSystem) + + +mkYesodSubData "DeskCom" [parseRoutes| + / DeskComLoginR GET + /m DeskComMaybeLoginR GET +|] diff --git a/yesod-auth-deskcom.cabal b/yesod-auth-deskcom.cabal --- a/yesod-auth-deskcom.cabal +++ b/yesod-auth-deskcom.cabal @@ -1,5 +1,5 @@ Name: yesod-auth-deskcom -Version: 1.1 +Version: 1.2 Synopsis: Desk.com remote authentication support for Yesod apps. Homepage: https://github.com/meteficha/yesod-auth-deskcom License: BSD3 @@ -30,25 +30,30 @@ Library hs-source-dirs: src - Build-depends: base >= 4.3 && < 5 - , time >= 1.1 && < 2 + Build-depends: base >= 4.3 && < 5 + , time >= 1.1 && < 2 , template-haskell - , transformers >= 0.1.3 && < 0.4 - , bytestring >= 0.9 - , text >= 0.7 && < 0.12 + , transformers >= 0.1.3 && < 0.4 + , bytestring >= 0.9 + , text >= 0.7 && < 0.12 , data-default - , base64-bytestring >= 1.0 - , cryptohash >= 0.6 - , cipher-aes >= 0.1 - , crypto-api >= 0.10 - , aeson >= 0.6 + , base64-bytestring >= 1.0 + , cryptohash >= 0.6 + , cryptohash-cryptoapi >= 0.1 + , cipher-aes >= 0.1 + , cprng-aes >= 0.3 + , crypto-api >= 0.10 + , aeson >= 0.6 , http-conduit - , http-types >= 0.7 - , yesod-core == 1.1.* - , yesod-auth == 1.1.* + , http-types >= 0.7 + , yesod-core == 1.2.* + , yesod-auth == 1.2.* Exposed-modules: Yesod.Auth.DeskCom + Other-modules: Yesod.Auth.DeskCom.Data Extensions: + ConstraintKinds + FlexibleContexts FlexibleInstances GADTs MultiParamTypeClasses