hsoz 0.0.0.4 → 0.0.1.0
raw patch · 14 files changed
+221/−259 lines, 14 filesdep −base16-bytestringdep −base64-bytestringdep −byteabledep ~aesondep ~attoparsecdep ~bytestring
Dependencies removed: base16-bytestring, base64-bytestring, byteable, securemem
Dependency ranges changed: aeson, attoparsec, bytestring, case-insensitive, containers, cryptonite, data-default, either, errors, exceptions, hashable, http-client, http-conduit, http-types, lens, memory, mtl, network, optparse-applicative, scientific, scotty, text, time, transformers, unordered-containers, uri-bytestring, vault, wai, warp
Files
- README.md +1/−1
- example/HawkClient.hs +14/−7
- example/Iron.hs +22/−19
- example/OzServer.hs +4/−2
- hsoz.cabal +38/−42
- src/Network/Hawk/Internal.hs +2/−2
- src/Network/Hawk/Internal/Client.hs +13/−12
- src/Network/Hawk/Server.hs +8/−7
- src/Network/Iron.hs +77/−101
- src/Network/Iron/Util.hs +7/−31
- src/Network/Oz/JSON.hs +1/−1
- src/Network/Oz/Ticket.hs +8/−11
- src/Network/Oz/Types.hs +3/−2
- test/Network/Iron/Tests.hs +23/−21
README.md view
@@ -1,6 +1,6 @@ # Oz Haskell Implementation -[](https://travis-ci.org/rvl/hsoz) []()+[](https://travis-ci.org/rvl/hsoz) [](http://hackage.haskell.org/package/hsoz) *hsoz* is a Haskell implementation of the Iron, Hawk, and Oz web authentication protocols. These protocols originate from the OAuth2
example/HawkClient.hs view
@@ -11,7 +11,8 @@ import qualified Data.Map as M import qualified Data.Text as T import Data.Text.Encoding (decodeUtf8, encodeUtf8)-import Network.HTTP.Client (HttpException (..))+import Network.HTTP.Client (HttpException(..), HttpExceptionContent(..))+import Network.HTTP.Client (responseStatus, responseHeaders) import Network.HTTP.Types.Header (ResponseHeaders, hAuthorization, hWWWAuthenticate) import Network.HTTP.Types.Status (Status(..)) import Network.HTTP.Simple@@ -47,12 +48,18 @@ where withHawk = Hawk.withHawk creds ext (Just payload) Hawk.ServerAuthorizationRequired handlers = [E.Handler handleHTTP, E.Handler handleHawk]- handleHTTP e@(StatusCodeException s hdrs _)- | statusCode s == 401 = S8.putStrLn $ errMessage s hdrs- | otherwise = throwIO e+ handleHTTP e@(HttpExceptionRequest _ (StatusCodeException res _))+ | unauthorized res = S8.putStrLn $ errMessage res+ | otherwise = throwIO e+ where code = statusCode (responseStatus res) handleHawk (Hawk.HawkServerAuthorizationException e) = putStrLn $ "Invalid server response: " ++ e -errMessage :: Status -> ResponseHeaders -> ByteString-errMessage s hdrs = statusMessage s <> maybe "" (": " <>) authHdr- where authHdr = lookup hWWWAuthenticate hdrs+unauthorized :: Response a -> Bool+unauthorized = (== 401) . statusCode . responseStatus++errMessage :: Response a -> ByteString+errMessage res = statusMessage s <> maybe "" (": " <>) authHdr+ where+ authHdr = lookup hWWWAuthenticate $ responseHeaders res+ s = responseStatus res
example/Iron.hs view
@@ -1,6 +1,8 @@ import Options.Applicative+import Data.Monoid ((<>))+import Data.Bifunctor (bimap) import Control.Monad (join, unless)-import Data.Time.Clock (NominalDiffTime)+import Data.Time.Clock (NominalDiffTime) import Text.Read (readEither) import Data.ByteString (ByteString) import qualified Data.ByteString.Lazy.Char8 as L8@@ -67,6 +69,18 @@ <> help "Encryption algorithm: AES128CTR or AES256CBC (default)" <> value AES256CBC )+ <*> option auto+ ( long "salt-bits"+ <> metavar "INTEGER"+ <> help "Number of salt bits for key generation."+ <> value 256+ )+ <*> option auto+ ( long "iterations"+ <> metavar "INTEGER"+ <> help "Number of iterations of key derivation function."+ <> value 100000+ ) ttl :: ReadM NominalDiffTime ttl = eitherReader (fmap fromInteger . readEither)@@ -74,12 +88,11 @@ data Action = Seal | Unseal data Format = JSONFormat | StringFormat -iron :: Either String String -> Maybe Action -> Format -> NominalDiffTime -> IronCipher -> IO ()-iron p a j ttl c = do+iron :: Either String String -> Maybe Action -> Format -> NominalDiffTime+ -> IronCipher -> Int -> Int -> IO ()+iron p a j ttl c s i = do p' <- password <$> readPassword p- let opts = def { ironEncryption = def { ieAlgorithm = c }- , ironTTL = ttl- }+ let opts = (options c SHA256 s i) { ironTTL = ttl } L8.hGetContents stdin >>= mapM_ (processLine opts p' a j) . L8.lines readPassword :: Either FilePath String -> IO ByteString@@ -115,23 +128,13 @@ conv :: Format -> L8.ByteString -> Either String Value conv JSONFormat = eitherDecode'-conv StringFormat = mapEither show (String . TL.toStrict) . decodeUtf8'+conv StringFormat = bimap show (String . TL.toStrict) . decodeUtf8' doSeal :: ToJSON a => Options -> Password -> a -> IO (Either String ByteString)-doSeal o p a = justRight "Failed to seal" <$> sealWith o p a+doSeal o p a = justRight "Failed to seal" <$> seal o p a doUnseal :: FromJSON a => Options -> Password -> L8.ByteString -> IO (Either String a)-doUnseal o p s = unsealWith o (const (Just p)) (L8.toStrict s)----- | Modifies the left branch of an 'Either'.-mapLeft :: (a -> a') -> Either a b -> Either a' b-mapLeft f (Left a) = Left (f a)-mapLeft _ (Right b) = Right b---- | Modifies both branches of an 'Either'.-mapEither :: (a -> a') -> (b -> b') -> Either a b -> Either a' b'-mapEither f g = mapLeft f . fmap g+doUnseal o p s = unseal o (const (Just p)) (L8.toStrict s) -- | Converts 'Maybe' to 'Either'. justRight :: e -> Maybe a -> Either e a
example/OzServer.hs view
@@ -126,8 +126,10 @@ otherwise -> False openTicket :: S8.ByteString -> IO (Either String OzTicket)-openTicket = Iron.unseal (password sharedKey)- where password (Hawk.Key p) = Iron.onePassword p+openTicket = Iron.unseal opts (password sharedKey)+ where+ opts = ticketOptsIron defaultTicketOpts+ password (Hawk.Key p) = Iron.onePassword p -- | Example apps registry apps = [OzApp "app123" Nothing False sharedKey (Hawk.HawkAlgo Hawk.SHA256)]
hsoz.cabal view
@@ -1,5 +1,5 @@ name: hsoz-version: 0.0.0.4+version: 0.0.1.0 synopsis: Iron, Hawk, Oz: Web auth protocols description: hsoz is a Haskell implementation of the Iron, Hawk, and Oz web@@ -25,8 +25,12 @@ cabal-version: >=1.10 stability: experimental bug-reports: https://github.com/rvl/hsoz/issues-Tested-With: GHC == 8.0.1+Tested-With: GHC == 8.0.2 +source-repository head+ type: git+ location: https://github.com/rvl/hsoz+ flag example description: Build the example applications default: True@@ -34,6 +38,7 @@ library hs-source-dirs: src exposed-modules: Network.Iron+ , Network.Iron.Util , Network.Hawk , Network.Hawk.Client , Network.Hawk.Middleware@@ -55,45 +60,40 @@ , Network.Oz.Server , Network.Oz.Ticket , Network.Oz.Types- other-modules: Network.Iron.Util- , Network.Hawk.Algo+ other-modules: Network.Hawk.Algo , Network.Hawk.Util , Network.Hawk.Internal.JSON , Network.Oz.JSON , Network.Oz.Internal.Types , Network.Oz.Boom build-depends: base >= 4.7 && < 5- , aeson- , attoparsec- , base16-bytestring- , base64-bytestring- , byteable- , bytestring- , case-insensitive- , containers- , cryptonite- , data-default- , either- , errors- , exceptions- , hashable- , http-client >= 0.4 && < 0.5- , http-types- , lens- , memory- , mtl- , network- , scientific- , scotty- , securemem- , text- , time- , transformers- , unordered-containers- , uri-bytestring- , vault- , wai- , warp+ , aeson >= 1.0.2 && < 1.1+ , attoparsec >= 0.13.1 && < 0.14+ , bytestring >= 0.10.8 && < 0.11+ , case-insensitive >= 1.2.0 && < 1.3+ , containers >= 0.5.7 && < 0.6+ , cryptonite >= 0.21 && < 0.22+ , data-default >= 0.7.1 && < 0.8+ , either >= 4.4.1 && < 4.5+ , errors >= 2.1.3 && < 2.2+ , exceptions >= 0.8.3 && < 0.9+ , hashable >= 1.2.5 && < 1.3+ , http-client >= 0.5.5 && < 0.6+ , http-types >= 0.9.1 && < 0.10+ , lens >= 4.15.1 && < 4.16+ , memory >= 0.14.1 && < 0.15+ , mtl >= 2.2.1 && < 2.3+ , network >= 2.6.3 && < 2.7+ , scientific >= 0.3.4 && < 0.4+ , scotty >= 0.11.0 && < 0.12+ , text >= 1.2.2 && < 1.3+ , time >= 1.6.0 && < 1.7+ , transformers >= 0.5.2 && < 0.6+ , unordered-containers >= 0.2.7 && < 0.3+ , uri-bytestring >= 0.2.2 && < 0.3+ , vault >= 0.3.0 && < 0.4+ , wai >= 3.2.1 && < 3.3+ , warp >= 3.2.11 && < 3.3 default-language: Haskell2010 default-extensions: OverloadedStrings @@ -121,8 +121,8 @@ , containers , cryptonite , data-default- , http-client >= 0.4 && < 0.5- , http-conduit >= 2.1 && < 2.2+ , http-client >= 0.5 && < 0.6+ , http-conduit >= 2.2 && < 2.3 , http-types , lens , lucid@@ -151,7 +151,7 @@ , containers , cryptonite , data-default- , optparse-applicative+ , optparse-applicative >= 0.12 , text , time default-language: Haskell2010@@ -183,7 +183,3 @@ ghc-options: -threaded -rtsopts -with-rtsopts=-N default-language: Haskell2010 default-extensions: OverloadedStrings--source-repository head- type: git- location: https://github.com/rvl/hsoz
src/Network/Hawk/Internal.hs view
@@ -28,7 +28,7 @@ import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy as BL import Data.Text.Encoding (encodeUtf8)-import Data.Byteable (constEqBytes)+import Data.ByteArray (constEq) import Data.Char (toLower, toUpper) import Data.List (intercalate) import Data.Monoid ((<>))@@ -66,7 +66,7 @@ checkPayload :: HawkAlgoCls a => Maybe ByteString -> a -> ContentType -> BL.ByteString -> Either String () checkPayload (Just hash) algo ct payload = if good then Right () else Left "Bad payload hash" where- good = hash `constEqBytes` (calculatePayloadHash algo payloadInfo)+ good = hash `constEq` (calculatePayloadHash algo payloadInfo) payloadInfo = PayloadInfo ct payload checkPayload Nothing algo ct payload = Left "Missing required payload hash"
src/Network/Hawk/Internal/Client.hs view
@@ -16,10 +16,9 @@ import qualified Data.ByteArray as BA (unpack) import Data.ByteString (ByteString) import qualified Data.ByteString as BS-import qualified Data.ByteString.Base64 as B64 import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy as BL-import Data.Byteable (constEqBytes)+import Data.ByteArray (constEq) import Data.CaseInsensitive (CI (..)) import qualified Data.Map as M import Data.Maybe (catMaybes, fromMaybe)@@ -32,9 +31,9 @@ import Network.HTTP.Types.Method (Method) import Network.HTTP.Types.Status (Status, statusCode) import Network.HTTP.Types.URI (extractPath)-import Network.HTTP.Client (Response, responseHeaders)+import Network.HTTP.Client (Response, responseHeaders, responseStatus) import Network.HTTP.Client (Request, requestHeaders, requestBody, getUri, method, secure)-import Network.HTTP.Client (HttpException(..))+import Network.HTTP.Client (HttpException(..), HttpExceptionContent(..)) import URI.ByteString (authorityHost, authorityPort, hostBS, laxURIParserOptions, parseURI, portNumber, uriAuthority,@@ -254,7 +253,7 @@ where tsm = calculateTsMac (ccAlgorithm creds) <$> wahTs h tsmEq :: Maybe ByteString -> Maybe ByteString -> Bool- tsmEq (Just a) (Just b) = a `constEqBytes` b+ tsmEq (Just a) (Just b) = a `constEq` b tsmEq (Just _) Nothing = False tsmEq _ _ = True @@ -266,7 +265,7 @@ checkServerAuthorizationHeader _ _ ServerAuthorizationRequired _ Nothing = Left "Missing Server-Authorization header" checkServerAuthorizationHeader creds arts _ now (Just sa) = parseServerAuthorizationHeader sa >>= check- where check sah | sahMac sah `constEqBytes` mac = Right (Just sah)+ where check sah | sahMac sah `constEq` mac = Right (Just sah) | otherwise = Left "Bad response mac" where arts' = responseArtifacts sah arts@@ -380,8 +379,8 @@ -> m a -> m (Either NominalDiffTime a) makeExpiryHandler creds req = E.handle handler . fmap Right where- handler e@(StatusCodeException s h _) =- case wasStale req creds h s of+ handler e@(HttpExceptionRequest req (StatusCodeException res _)) =+ case wasStale req res creds of Just ts -> return $ Left ts Nothing -> throwM e @@ -411,10 +410,12 @@ liftIO $ authenticate resp creds arts body ck ServerAuthorizationNotRequired -> return (Right Nothing) -wasStale :: Request -> Credentials -> ResponseHeaders -> Status -> Maybe NominalDiffTime-wasStale req creds hdrs s- | secure req && statusCode s == 401 = hawkTs creds hdrs- | otherwise = Nothing+wasStale :: Request -> Response () -> Credentials -> Maybe NominalDiffTime+wasStale req res creds | secure req && unauthorized = serverTs+ | otherwise = Nothing+ where+ unauthorized = statusCode (responseStatus res) == 401+ serverTs = hawkTs creds (responseHeaders res) -- | Gets the WWW-Authenticate header value and returns the server -- timestamp, if the response contains an authenticated timestamp.
src/Network/Hawk/Server.hs view
@@ -43,7 +43,7 @@ import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy as BL-import Data.Byteable (constEqBytes)+import Data.ByteArray (constEq) import Data.CaseInsensitive (CI (..)) import Data.Maybe (fromMaybe) import Data.Monoid ((<>))@@ -51,6 +51,7 @@ import qualified Data.Text as T import Data.Text.Encoding (decodeUtf8, decodeUtf8') import Control.Error.Safe (rightMay)+import Data.Bifunctor (first) import Data.Default (Default(..)) import Data.Time.Clock (NominalDiffTime) import Data.Time.Clock.POSIX@@ -68,7 +69,7 @@ import Network.Hawk.Internal.Server.Types import Network.Hawk.Internal.Server.Header import Network.Hawk.Util-import Network.Iron.Util (b64urldec, justRight, mapLeft)+import Network.Iron.Util (b64urldec, justRight) -- | Bundle of parameters for 'authenticateRequest'. Provides -- information about what the public URL of the server would be. If@@ -119,7 +120,7 @@ else authenticate (saOpts opts) creds hreq authenticateBewit' (creds, t) req bewit- | mac `constEqBytes` (bewitMac bewit) = Right (AuthSuccess creds arts t)+ | mac `constEq` (bewitMac bewit) = Right (AuthSuccess creds arts t) | otherwise = Left (AuthFailUnauthorized "Bad mac" (Just creds) (Just arts)) where arts = bewitArtifacts req bewit@@ -146,7 +147,7 @@ now <- getServerTime opts case checkBewit hrq now of Right bewit -> do- mcreds <- mapLeft unauthorized <$> getCreds (bewitId bewit)+ mcreds <- first unauthorized <$> getCreds (bewitId bewit) return $ case mcreds of Right creds -> authenticateBewit' creds hrq bewit Left e -> undefined@@ -159,7 +160,7 @@ checkLength hrqUrl encBewit <- checkEmpty hrqBewit checkHeader hrqAuthorization- bewit <- mapLeft unauthorized $ decodeBewit encBewit+ bewit <- first unauthorized $ decodeBewit encBewit checkAttrs bewit checkExpiry bewit now return bewit@@ -294,7 +295,7 @@ let doCheck = authResult creds arts t doCheckExp = authResultExp now creds arts t mac = serverMac creds ty arts- if mac `constEqBytes` sahMac then do+ if mac `constEq` sahMac then do doCheck $ checkPayloadHash (scAlgorithm creds) sahHash payload doCheck $ checkNonce nonce doCheckExp $ checkExpiration now (saTimestampSkew opts) sahTs@@ -399,7 +400,7 @@ bewit' (id, exp, mac, ext) = Bewit <$> decodeId id <*> readTsMaybe exp <*> pure mac <*> pure ext- fixMsg = mapLeft (const "Invalid bewit encoding")+ fixMsg = first (const "Invalid bewit encoding") decodeId = rightMay . decodeUtf8' ----------------------------------------------------------------------------
src/Network/Iron.hs view
@@ -23,9 +23,10 @@ -- >>> import Data.ByteString (ByteString) -- >>> import Data.Aeson -- >>> import qualified Network.Iron as Iron+-- >>> let opts = Iron.options Iron.AES256CBC Iron.SHA256 256 66666 -- >>> let Just obj = decode "{\"a\":1,\"d\":{\"e\":\"f\"},\"b\":2,\"c\":[3,4,5]}" :: Maybe Object -- >>> let secret = "some_not_random_password" :: ByteString--- >>> s <- Iron.seal (Iron.password secret) obj+-- >>> Just s <- Iron.seal opts (Iron.password secret) obj -- >>> print s -- "Fe26.2**3976da2bc627b3551c1ebfe40376bb791efb17f4425facc648038fdaaa2f67b2 -- *voiPExJrXAxmTWyQr7-Hvw*r_Ok7NOgy9sD2fS61t_u9z8qoszwBRze3NnA6PFmjnd06sLh0@@ -37,7 +38,7 @@ -- -- To unseal the string: ----- >>> Iron.unseal (onePassword secret) s :: IO (Either String Object)+-- >>> Iron.unseal opts (onePassword secret) s :: IO (Either String Object) -- Right (Object (fromList [("a",Number 1.0), -- ("d",Object (fromList [("e",String "f")])), -- ("b",Number 2.0),@@ -45,9 +46,8 @@ module Network.Iron ( seal- , sealWith , unseal- , unsealWith+ , options , password , passwords , passwordWithId@@ -60,11 +60,8 @@ , EncryptionOpts(..) , IntegrityOpts(..) , IronCipher(..)- , IronMAC(..)- , SHA256(SHA256)- , IronSalt(..)- , urlSafeBase64- , def+ , IronHMAC(..)+ , Salt(..) ) where import Control.Monad (liftM, when)@@ -72,8 +69,8 @@ import Crypto.Cipher.Types import Crypto.Data.Padding import Crypto.Error (CryptoFailable (..), maybeCryptoError)-import Crypto.Hash.Algorithms (SHA256 (..))-import Crypto.Hash.Algorithms (SHA1 (..))+import qualified Crypto.Hash.Algorithms as C (SHA256 (..))+import Crypto.Hash.Algorithms (HashAlgorithm(..), SHA1 (..)) import qualified Crypto.KDF.PBKDF2 as PBKDF2 import Crypto.MAC.HMAC (Context, HMAC, finalize, hmac, hmacGetDigest, initialize, updates)@@ -82,15 +79,13 @@ import qualified Data.Aeson as JSON (eitherDecode', encode) import Data.ByteString (ByteString) import qualified Data.ByteString as BS-import qualified Data.ByteString.Base16 as B16 import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy as BL-import Data.SecureMem (SecureMem(..), ToSecureMem(..))-import Data.Byteable (Byteable(..), constEqBytes)+import qualified Data.ByteArray as BA+import Data.ByteArray (ScrubbedBytes, ByteArrayAccess) import qualified Data.Map as M import Data.Maybe (fromJust) import Data.Monoid ((<>))-import Data.Default (Default(..)) import Data.Text (Text) import Data.Text.Encoding (decodeUtf8, encodeUtf8) import Data.Char (isAscii, isAlphaNum)@@ -99,14 +94,7 @@ import Network.Iron.Util import Numeric (showHex) --- | Iron options used by 'sealWith' and 'unsealWith'. The--- default options are:------ * Encryption: 'Crypto.Cipher.AES.AES256' using CBC mode--- * Integrity HMAC: 'Crypto.Hash.Algorithms.SHA256'--- * Infinite message lifetime--- * Timestamp skew: 60 seconds either way--- * Local time offset: 0+-- | Iron options used by 'sealWith' and 'unsealWith'. data Options = Options { ironEncryption :: EncryptionOpts -- ^ Encryption options , ironIntegrity :: IntegrityOpts -- ^ Message integrity verification options@@ -117,6 +105,7 @@ -- | Encryption algorithms supported by Iron. data IronCipher = AES128CTR | AES256CBC deriving (Show, Read, Eq, Enum)+data IronHMAC = SHA256 deriving (Show, Read, Eq, Enum) class IsIronCipher a where ivSize :: a -> Int@@ -128,20 +117,13 @@ macKeySize :: a -> Int ironMac :: a -> ByteString -> ByteString -> ByteString --- | Integrity checking algorithm supported by Iron. At present, there--- is only one. Use @IronMAC SHA256@.-data IronMAC = forall alg . (IsIronMAC alg, Show alg) => IronMAC alg--instance Show IronMAC where- show (IronMAC alg) = show alg--instance IsIronMAC IronMAC where- macKeySize (IronMAC alg) = macKeySize alg- ironMac (IronMAC alg) = ironMac alg+instance IsIronMAC IronHMAC where+ macKeySize SHA256 = 32+ ironMac SHA256 key text = b64url $ hmacGetDigest (hmac key text :: HMAC C.SHA256) -- | Specifies the salt for password-based key generation.-data IronSalt = IronSalt ByteString -- ^ Supply pre-generated salt- | IronGenSalt Int -- ^ Generate salt of given size, in bits+data Salt = Salt ByteString -- ^ Supply pre-generated salt+ | GenSalt Int -- ^ Generate salt of given size, in bits deriving Show {-@@ -152,7 +134,7 @@ -- | Options controlling encryption of Iron messages. data EncryptionOpts = EncryptionOpts- { ieSalt :: IronSalt -- ^ Salt for password-based key generation+ { ieSalt :: Salt -- ^ Salt for password-based key generation , ieAlgorithm :: IronCipher -- ^ Encryption algorithm , ieIterations :: Int -- ^ Number of iterations for password-based key generation , ieIV :: Maybe ByteString -- ^ Pre-generated initial value block@@ -160,42 +142,50 @@ -- | Options controlling cryptographic verification of Iron messages. data IntegrityOpts = IntegrityOpts- { iiSalt :: IronSalt -- ^ Salt for MAC key generation- , iiAlgorithm :: IronMAC -- ^ Hash-based MAC algorithm+ { iiSalt :: Salt -- ^ Salt for MAC key generation+ , iiAlgorithm :: IronHMAC -- ^ Hash-based MAC algorithm , iiIterations :: Int -- ^ Number of iterations for MAC key generation } deriving Show -defaultsEncrypt :: IronCipher -> EncryptionOpts-defaultsEncrypt algo = EncryptionOpts- { ieSalt = IronGenSalt 256- , ieAlgorithm = algo- , ieIterations = 1+encryptOptions :: IronCipher -- ^ Cipher algorithm+ -> Int -- ^ Number of salt bits for key generation+ -> Int -- ^ Number of iterations of key derivation function+ -> EncryptionOpts+encryptOptions a s n = EncryptionOpts+ { ieSalt = GenSalt s+ , ieAlgorithm = a+ , ieIterations = n , ieIV = Nothing } -defaultsIntegrity :: IronMAC -> IntegrityOpts-defaultsIntegrity algo = IntegrityOpts- { iiSalt = IronGenSalt 256- , iiAlgorithm = algo- , iiIterations = 1 }+integrityOptions :: IronHMAC -- ^ Cryptographic hash algorithm+ -> Int -- ^ Number of salt bits for key generation+ -> Int -- ^ Number of iterations of key derivation function+ -> IntegrityOpts+integrityOptions a s n = IntegrityOpts+ { iiSalt = GenSalt s+ , iiAlgorithm = a+ , iiIterations = n } -defaults :: Options-defaults = Options- { ironEncryption = def- , ironIntegrity = def+-- | A set of basic options. You need to choose a cipher and+-- parameters for key generation.+--+-- There are also some default options chosen, which are:+-- * Infinite message lifetime+-- * Timestamp skew: 60 seconds either way+-- * Local time offset: 0+options :: IronCipher -- ^ Encryption algorithm.+ -> IronHMAC -- ^ Integrity check algorithm (use @SHA256@).+ -> Int -- ^ Number of salt bits for key generation.+ -> Int -- ^ Number of iterations of key derivation function.+ -> Options+options e i s n = Options+ { ironEncryption = encryptOptions e s n+ , ironIntegrity = integrityOptions i s n , ironTTL = 0 , ironTimestampSkew = 60 , ironLocaltimeOffset = 0 } -instance Default EncryptionOpts where- def = defaultsEncrypt AES256CBC--instance Default IntegrityOpts where- def = defaultsIntegrity (IronMAC SHA256)--instance Default Options where- def = defaults- -- | Identifies the password to use when unsealing the message. type PasswordId = ByteString @@ -210,25 +200,25 @@ -- | Represents a key used for the cipher or message authentication -- code, or a password from which a key will be generated.-data KeyPass = Key SecureMem -- ^ Pre-generated key- | Password SecureMem -- ^ Key derived from password+data KeyPass = Key ScrubbedBytes -- ^ Pre-generated key+ | Password ScrubbedBytes -- ^ Key derived from password deriving (Show, Eq)- -- note: SecureMem Show doesn't actually show any content+ -- note: ScrubbedBytes Show doesn't actually show any content -- | Constructs a 'Password'.-password :: ToSecureMem a => a -> Password+password :: ByteArrayAccess a => a -> Password password p = passwords p p -- | Constructs a 'Password', with different encryption and integrity -- verification passwords.-passwords :: ToSecureMem a => a -> a -> Password+passwords :: ByteArrayAccess a => a -> a -> Password passwords e i = password' mempty e i -- | Constructs a 'Password'. The given identifier will be included as -- the second component of the the sealed @Fe26@ string. The -- identifier must only include alphanumeric characters and the -- underscore, otherwise nothing will be returned.-passwordWithId :: ToSecureMem a => PasswordId -> a -> Maybe Password+passwordWithId :: ByteArrayAccess a => PasswordId -> a -> Maybe Password passwordWithId k p = passwordsWithId k p p -- | Constructs a 'Password', with different encryption and integrity@@ -236,7 +226,7 @@ -- the second component of the the sealed @Fe26@ string. The -- identifier must only include alphanumeric characters and the -- underscore, otherwise nothing will be returned.-passwordsWithId :: ToSecureMem a => PasswordId -> a -> a -> Maybe Password+passwordsWithId :: ByteArrayAccess a => PasswordId -> a -> a -> Maybe Password passwordsWithId k e i | validId k = Just $ password' k e i | otherwise = Nothing @@ -244,12 +234,12 @@ validId k = not (S8.null k) && S8.all inRange k where inRange c = isAscii c && isAlphaNum c || c == '_' -passwordValid :: Byteable a => EncryptionOpts -> a -> Bool-passwordValid EncryptionOpts{..} sec = keySize ieAlgorithm <= byteableLength sec+passwordValid :: ByteArrayAccess a => EncryptionOpts -> a -> Bool+passwordValid EncryptionOpts{..} sec = keySize ieAlgorithm <= BA.length sec -password' :: ToSecureMem a => PasswordId -> a -> a -> Password+password' :: ByteArrayAccess a => PasswordId -> a -> a -> Password password' k e i = MkPassword k (passwd e) (passwd i)- where passwd = Password . toSecureMem+ where passwd = Password . BA.convert -- | User-supplied function to get the password corresponding to the -- identifier from the sealed message.@@ -257,19 +247,14 @@ -- | The simple case of LookupPassword, where there is the same -- password for encryption and verification of all messages.-onePassword :: ToSecureMem a => a -> LookupPassword+onePassword :: ByteArrayAccess a => a -> LookupPassword onePassword = const . Just . password -- | Encodes and encrypts a 'Data.Aeson.Value' using the given--- password.-seal :: ToJSON a => Password -> a -> IO ByteString-seal password = liftM fromJust <$> sealWith defaults password---- | Encodes and encrypts a 'Data.Aeson.Value' using the given -- password and 'Options'. Encryption may fail if the supplied -- options are wrong.-sealWith :: ToJSON a => Options -> Password -> a -> IO (Maybe ByteString)-sealWith opts p v = do+seal :: ToJSON a => Options -> Password -> a -> IO (Maybe ByteString)+seal opts p v = do s <- getSealStuff opts return $ seal' opts s p v @@ -373,23 +358,19 @@ expTime Options{ironTTL} now | ironTTL > 0 = Just ((now + ironTTL) * 1000) | otherwise = Nothing -instance IsIronMAC SHA256 where- macKeySize _ = 32- ironMac _ key text = b64 $ hmacGetDigest (hmac key text :: HMAC SHA256)- -- | Calculates the MAC of a message. The result is encoded in the -- URL-friendly variant of Base64.-macWithKey :: IronMAC -> ByteString -> ByteString -> ByteString-macWithKey algo key text = urlSafeBase64 (ironMac algo key text)+macWithKey :: IronHMAC -> ByteString -> ByteString -> ByteString+macWithKey algo key text = ironMac algo key text generateKey :: Int -> Int -> ByteString -> KeyPass -> Either String ByteString-generateKey _ s _ (Key k) | byteableLength k >= s = Right (toBytes k)+generateKey _ s _ (Key k) | BA.length k >= s = Right (BA.convert k) | otherwise = Left "Key buffer (password) too small" generateKey n s l (Password p) | BS.null l = Left "Missing salt" | otherwise = Right (generateKey' n s l p) -generateKey' :: Byteable p => Int -> Int -> ByteString -> p -> ByteString-generateKey' iterations size salt p = PBKDF2.generate prf params (toBytes p) salt+generateKey' :: BA.ByteArrayAccess p => Int -> Int -> ByteString -> p -> ByteString+generateKey' iterations size salt p = PBKDF2.generate prf params p salt where prf = PBKDF2.prfHMAC SHA1 params = PBKDF2.Parameters iterations size@@ -443,14 +424,9 @@ unpad p text' -- | Decrypts an Iron-encoded message 'Data.Aeson.Value' with the--- given password.-unseal :: FromJSON a => LookupPassword -> ByteString -> IO (Either String a)-unseal p = unsealWith defaults p---- | Decrypts an Iron-encoded message 'Data.Aeson.Value' with the -- given password and 'Options'.-unsealWith :: FromJSON a => Options -> LookupPassword -> ByteString -> IO (Either String a)-unsealWith opts p t = do+unseal :: FromJSON a => Options -> LookupPassword -> ByteString -> IO (Either String a)+unseal opts p t = do now <- getPOSIXTime return $ unseal' opts now p t @@ -475,7 +451,7 @@ verify :: Cookie -> KeyPass -> Either String () verify Cookie{..} sec = do digest <- hmacWithPassword (ironIntegrity opts) sec ckIntSalt ckEnc- if constEqBytes ckIntDigest digest+ if BA.constEq ckIntDigest digest then Right () else Left "Bad hmac value" @@ -494,14 +470,14 @@ isExpired now skew (Just exp) = exp <= (now - skew) genSalt :: DRG gen => Int -> gen -> (ByteString, gen)-genSalt saltBits gen = withRandomBytes gen (saltBits `quot` 8) B16.encode+genSalt saltBits gen = withRandomBytes gen (saltBits `quot` 8) b16 genIV :: DRG gen => Int -> gen -> (ByteString, gen) genIV size gen = withRandomBytes gen size id -genSaltMaybe :: DRG gen => IronSalt -> gen -> (ByteString, gen)-genSaltMaybe (IronSalt salt) = \gen -> (salt, gen)-genSaltMaybe (IronGenSalt len) = genSalt len+genSaltMaybe :: DRG gen => Salt -> gen -> (ByteString, gen)+genSaltMaybe (Salt salt) = \gen -> (salt, gen)+genSaltMaybe (GenSalt len) = genSalt len genIVMaybe :: DRG gen => IronCipher -> Maybe ByteString -> gen -> (ByteString, gen) genIVMaybe _ (Just iv) = \gen -> (iv, gen)
src/Network/Iron/Util.hs view
@@ -6,53 +6,38 @@ , b64dec , b64url , b64urldec- , urlSafeBase64- , unUrlSafeBase64+ , b16 -- * Time parsing , parseExpMsec -- * Error handling , justRight , rightJust- , mapLeft ) where -import Crypto.Hash import Data.ByteArray (ByteArrayAccess) import qualified Data.ByteArray.Encoding as B (Base (..), convertToBase, convertFromBase) import Data.ByteString (ByteString)-import qualified Data.ByteString as BS (pack, unpack) import qualified Data.ByteString.Char8 as S8 import Data.Monoid ((<>)) import Data.Time.Clock (NominalDiffTime) import Text.Read (readMaybe) +-- | Shorthand for hex encode+b16 :: ByteString -> ByteString+b16 = B.convertToBase B.Base16+ -- | Shorthand for encode in Base64. b64 :: ByteArrayAccess a => a -> ByteString b64 = B.convertToBase B.Base64 b64url :: ByteArrayAccess a => a -> ByteString-b64url = urlSafeBase64 . b64+b64url = B.convertToBase B.Base64URLUnpadded b64dec :: ByteArrayAccess a => a -> Either String ByteString b64dec = B.convertFromBase B.Base64 b64urldec :: ByteString -> Either String ByteString-b64urldec = b64dec . unUrlSafeBase64---- | Fixes up a Base64 encoded string so that it's more convenient to--- include in URLs. The padding @=@ signs are removed, and the--- characters @+@ and @/@ are replaced with @-@ and @_@.-urlSafeBase64 :: ByteString -> ByteString-urlSafeBase64 = S8.filter (/= '=') . S8.map (tr '+' '-' . tr '/' '_')- where- tr a b c = if c == a then b else c---- | The inverse of 'urlSafeBase64'.-unUrlSafeBase64 :: ByteString -> ByteString-unUrlSafeBase64 = pad . S8.map (tr '-' '+' . tr '_' '/')- where- tr a b c = if c == a then b else c- pad s = s <> S8.replicate (S8.length s `mod` 4) '='+b64urldec = B.convertFromBase B.Base64URLUnpadded -- | Reads a positive integer time value in milliseconds. This is for -- parsing ttls or expiry times written as milliseconds since the unix@@ -75,12 +60,3 @@ justRight :: e -> Maybe a -> Either e a justRight _ (Just a) = Right a justRight e Nothing = Left e---- | Modifies the left branch of an 'Either'.-mapLeft :: (a -> a') -> Either a b -> Either a' b-mapLeft f (Left a) = Left (f a)-mapLeft _ (Right b) = Right b---- | Modifies both branches of an 'Either'.-mapEither :: (a -> a') -> (b -> b') -> Either a b -> Either a' b'-mapEither f g = mapLeft f . fmap g
src/Network/Oz/JSON.hs view
@@ -18,7 +18,7 @@ import Network.Oz.Types fieldModifier :: String -> String-fieldModifier = drop 1 . dropWhile (/= '_') . dropWhile (== '_') . camelTo '_'+fieldModifier = drop 1 . dropWhile (/= '_') . dropWhile (== '_') . camelTo2 '_' opts = defaultOptions { JSON.fieldLabelModifier = fieldModifier }
src/Network/Oz/Ticket.hs view
@@ -17,12 +17,13 @@ import Control.Monad.IO.Class (MonadIO (..), liftIO) import Control.Applicative ((<|>)) import Data.Monoid ((<>))+import Data.Bifunctor (first) import Crypto.Random import Data.Aeson (Object (..), Value (..), object, toJSON) import Data.ByteString (ByteString) import qualified Data.ByteString as BS-import qualified Data.ByteString.Base64 as B64+import qualified Data.ByteArray.Encoding as B (Base (..), convertToBase, convertFromBase) import Data.List (isInfixOf, nub) import Data.Maybe (catMaybes, fromMaybe, isJust) import Data.Text (Text)@@ -44,7 +45,7 @@ rsvp :: MonadIO m => OzAppId -> Maybe OzGrantId -> Key -> TicketOpts -> m (Maybe ByteString) rsvp app grant (Key p) TicketOpts{..} = liftIO $ do now <- getPOSIXTime- Iron.sealWith ticketOptsIron (Iron.password p) (envelope now)+ Iron.seal ticketOptsIron (Iron.password p) (envelope now) where envelope now = OzTicket { ozTicketExp = now + ticketOptsRsvpTtl@@ -131,11 +132,11 @@ -- | Validate a grant scope in comparison to an app scope. checkGrantScope :: Maybe OzScope -> Maybe OzScope -> Either String (Maybe OzScope)-checkGrantScope app grant = mapLeft (const msg) (checkScopes app grant)+checkGrantScope app grant = first (const msg) (checkScopes app grant) where msg = "Grant scope is not a subset of the application scope" checkParentScope :: Maybe OzScope -> Maybe OzScope -> Either String (Maybe OzScope)-checkParentScope parent scope = mapLeft (const msg) (checkScopes parent scope)+checkParentScope parent scope = first (const msg) (checkScopes parent scope) where msg = "New scope is not a subset of the parent ticket scope" checkScopes :: Maybe OzScope -> Maybe OzScope -> Either String (Maybe OzScope)@@ -151,10 +152,6 @@ | length (nub scope) /= length scope = Left "scope includes duplicated item" | otherwise = Right scope -mapLeft :: (a -> c) -> Either a b -> Either c b-mapLeft f (Left a) = Left (f a)-mapLeft _ (Right b) = Right b- randomKey :: TicketOpts -> IO ByteString randomKey TicketOpts{..} = do -- fixme: check that this is seeded properly@@ -162,7 +159,7 @@ return (fst $ withRandomBytes drg ticketOptsKeyBytes base64) base64 :: ByteString -> ByteString-base64 = Iron.urlSafeBase64 . B64.encode+base64 = B.convertToBase B.Base64URLUnpadded -- | Adds the cryptographic properties to a ticket and prepares it for -- sending.@@ -171,7 +168,7 @@ key <- randomKey opts let Object ext = toJSON ticketOptsExt let sealed = OzSealedTicket t (Key key) ticketOptsHmacAlgorithm ext ""- mid <- Iron.sealWith ticketOptsIron (Iron.password p) sealed+ mid <- Iron.seal ticketOptsIron (Iron.password p) sealed return (finishSeal ticketOptsExt sealed <$> mid) -- | Removes the private ext part and adds the ticket ID.@@ -182,5 +179,5 @@ -- | Decodes a Hawk "app" string into an Oz Ticket. parse :: TicketOpts -> Key -> ByteString -> IO (Either String OzSealedTicket)-parse TicketOpts{..} (Key p) = Iron.unsealWith ticketOptsIron lookup+parse TicketOpts{..} (Key p) = Iron.unseal ticketOptsIron lookup where lookup = Iron.onePassword p
src/Network/Oz/Types.hs view
@@ -34,7 +34,7 @@ import Network.Hawk (HawkAlgo) import Network.Hawk.Types-import qualified Network.Iron as Iron (Options(..))+import qualified Network.Iron as Iron -- | Identifies an Oz Application type OzAppId = Text@@ -171,7 +171,8 @@ } defaultTicketOpts :: TicketOpts-defaultTicketOpts = TicketOpts 3600 60 True def 32 (HawkAlgo SHA256) mempty+defaultTicketOpts = TicketOpts 3600 60 True iron 32 (HawkAlgo SHA256) mempty+ where iron = Iron.options Iron.AES256CBC Iron.SHA256 256 100000 instance Default TicketOpts where def = defaultTicketOpts
test/Network/Iron/Tests.hs view
@@ -13,7 +13,6 @@ import Data.Either (isLeft) import Data.Aeson import Data.Time.Clock (NominalDiffTime)-import Data.Default (def) import Test.QuickCheck import Test.QuickCheck.Monadic@@ -114,15 +113,15 @@ instance Arbitrary IntegrityOpts where arbitrary = IntegrityOpts <$> arbitrary <*> arbitrary <*> choose (1, 3) -instance Arbitrary IronSalt where- -- arbitrary = oneof [IronSalt <$> arbitrary, pure $ IronGenSalt 256]- arbitrary = pure (IronGenSalt 256)+instance Arbitrary Salt where+ -- arbitrary = oneof [Salt <$> arbitrary, pure $ GenSalt 256]+ arbitrary = pure (GenSalt 256) instance Arbitrary IronCipher where arbitrary = oneof (map pure [AES128CTR, AES256CBC]) -instance Arbitrary IronMAC where- arbitrary = pure (IronMAC SHA256)+instance Arbitrary IronHMAC where+ arbitrary = pure SHA256 data Test1 a = Test1 { test1Obj :: a@@ -136,26 +135,29 @@ prop_test :: (ToJSON a, FromJSON a, Eq a) => Test1 a -> Property prop_test Test1{..} = monadicIO $ do obj' <- run $ do- s <- seal test1Password test1Obj- Right m <- unseal (onePassword' test1Password) s+ Just s <- seal testOpts test1Password test1Obj+ Right m <- unseal testOpts (onePassword' test1Password) s return m assert (obj' == obj) +testOpts :: Options+testOpts = options AES256CBC SHA256 256 1+ -- turns object into a ticket than parses the ticket successfully prop_test1 :: Object -> Property prop_test1 o = monadicIO $ do obj' <- run $ do- s <- seal defaultPassword o- unseal lookupPassword s+ Just s <- seal testOpts defaultPassword o+ unseal testOpts lookupPassword s assert (obj' == Right obj) -- unseal and sealed object with expiration prop_test2 :: NominalDiffTime -> Property prop_test2 ttl = monadicIO $ do- let opts = def { ironTTL = ttl }+ let opts = testOpts { ironTTL = ttl } obj' <- run $ do- Just s <- sealWith opts defaultPassword obj- unseal lookupPassword s+ Just s <- seal opts defaultPassword obj+ unseal opts lookupPassword s assert (obj' == Right obj) -- unseal and sealed object with expiration and time offset@@ -166,8 +168,8 @@ { ironLocaltimeOffset = negate (testTTL + 100) , ironTTL = testTTL } mobj' <- run $ do- Just s <- sealWith opts test1Password test1Obj- unseal (onePassword' test1Password) s+ Just s <- seal opts test1Password test1Obj+ unseal opts (onePassword' test1Password) s assert (testTTL == 0 || isErr mobj') assert (testTTL /= 0 || mobj' == Right test1Obj) @@ -186,8 +188,8 @@ prop_test4 :: ToJSON a => Test1 a -> Property prop_test4 Test1{..} = monadicIO $ do mobj' <- run $ do- Just s <- sealWith test1Opts defaultPassword test1Obj- unseal (const Nothing) s :: IO (Either String Object)+ Just s <- seal test1Opts defaultPassword test1Obj+ unseal test1Opts (const Nothing) s :: IO (Either String Object) assert (mobj' == Left "Cannot find password: default") -- ## generateKey@@ -240,13 +242,13 @@ -- unseals a ticket testUnseal01 :: Assertion testUnseal01 = do- r <- unseal lookupPassword ticket01+ r <- unseal testOpts lookupPassword ticket01 r @?= Right obj -- | Asserts that unsealing a ticket fails with the given message unsealFail :: ByteString -> String -> Assertion unsealFail ticket msg = do- r <- unseal lookupPassword ticket :: IO (Either String Object)+ r <- unseal testOpts lookupPassword ticket :: IO (Either String Object) r @?= Left msg -- returns an error when number of sealed components is wrong@@ -265,12 +267,12 @@ -- returns an error when decryption fails testUnseal05 :: Assertion-testUnseal05 = unsealFail ticket "base64: input: invalid encoding at offset: 64"+testUnseal05 = unsealFail ticket "base64URL unpadded: input: invalid encoding at offset: 64" where ticket = "Fe26.2**a6dc6339e5ea5dfe7a135631cf3b7dcf47ea38246369d45767c928ea81781694*D3DLEoi-Hn3c972TPpZXqw*mCBhmhHhRKk9KtBjwu3h-1lx1MHKkgloQPKRkQZxpnDwYnFkb3RqdVTQRcuhGf4M??**ff2bf988aa0edf2b34c02d220a45c4a3c572dac6b995771ed20de58da919bfa5*n04AwdA-1wOnGusZJVjoZC9sbAPfBRCnd4iVyX2yM2Y" -- returns an error when iv base64 decoding fails testUnseal06 :: Assertion-testUnseal06 = unsealFail ticket "base64: input: invalid encoding at offset: 22"+testUnseal06 = unsealFail ticket "base64URL unpadded: input: invalid encoding at offset: 22" where ticket = "Fe26.2**a6dc6339e5ea5dfe7a135631cf3b7dcf47ea38246369d45767c928ea81781694*D3DLEoi-Hn3c972TPpZXqw??*mCBhmhHhRKk9KtBjwu3h-1lx1MHKkgloQPKRkQZxpnDwYnFkb3RqdVTQRcuhGf4M**ff2bf988aa0edf2b34c02d220a45c4a3c572dac6b995771ed20de58da919bfa5*iF6pSFeSD8iYRlYIfD6VRwADFjFR3fX6hM_kIjN3_ew" -- returns an error when decrypted object is invalid