hsoz (empty) → 0.0.0.2

raw patch · 43 files changed

+3857/−0 lines, 43 filesdep +HUnitdep +QuickCheckdep +aesonsetup-changedbinary-added

Dependencies added: HUnit, QuickCheck, aeson, attoparsec, base, base16-bytestring, base64-bytestring, byteable, bytestring, case-insensitive, containers, cryptonite, data-default, either, errors, hsoz, http-client, http-conduit, http-types, lens, lucid, memory, mtl, network, scientific, scotty, securemem, tasty, tasty-golden, tasty-hunit, tasty-quickcheck, text, time, transformers, uri-bytestring, vault, wai, warp, wreq

Files

• Setup.hs +2/−0
• example/BewitClient.hs +29/−0
• example/BewitServer.hs +24/−0
• example/Common.hs +6/−0
• example/HawkClient.hs +40/−0
• example/HawkServer.hs +53/−0
• example/Main.hs +39/−0
• example/OzClient.hs +4/−0
• example/OzServer.hs +152/−0
• hsoz.cabal +186/−0
• images/haddock.png binary
• images/hawk-logo.png binary
• images/hawk.png binary
• images/iron-logo.png binary
• images/iron.png binary
• images/oz.png binary
• src/Network/Hawk.hs +53/−0
• src/Network/Hawk/Algo.hs +66/−0
• src/Network/Hawk/Client.hs +226/−0
• src/Network/Hawk/Client/HeaderParser.hs +52/−0
• src/Network/Hawk/Client/Types.hs +50/−0
• src/Network/Hawk/Common.hs +124/−0
• src/Network/Hawk/Middleware.hs +67/−0
• src/Network/Hawk/Server.hs +330/−0
• src/Network/Hawk/Server/Types.hs +90/−0
• src/Network/Hawk/Types.hs +31/−0
• src/Network/Hawk/URI.hs +46/−0
• src/Network/Hawk/Util.hs +97/−0
• src/Network/Iron.hs +511/−0
• src/Network/Iron/Util.hs +82/−0
• src/Network/Oz.hs +45/−0
• src/Network/Oz/Application.hs +223/−0
• src/Network/Oz/Boom.hs +77/−0
• src/Network/Oz/Client.hs +119/−0
• src/Network/Oz/Internal/Types.hs +24/−0
• src/Network/Oz/JSON.hs +99/−0
• src/Network/Oz/Server.hs +79/−0
• src/Network/Oz/Ticket.hs +185/−0
• src/Network/Oz/Types.hs +195/−0
• test/Main.hs +14/−0
• test/Network/Hawk/Tests.hs +142/−0
• test/Network/Iron/Tests.hs +287/−0
• test/Network/Oz/Tests.hs +8/−0

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,29 @@+module BewitClient where++import           Control.Exception          as E+import           Control.Lens+import           Data.ByteString            (ByteString)+import qualified Data.ByteString            as BS+import qualified Data.ByteString.Char8      as S8+import qualified Data.ByteString.Lazy.Char8 as L8+import           Network.HTTP.Client        (HttpException (..))+import           Network.Wreq+import           Data.Monoid++import           Common+import           Network.Hawk+import qualified Network.Hawk.Client        as Hawk++clientMain :: IO ()+clientMain =+  let uri = "http://localhost:8000/resource/1?b=1&a=2"+      creds = Hawk.Credentials "dh37fgj492je" sharedKey (HawkAlgo SHA256)+  in do+    res <- Hawk.getBewit creds 60 Nothing 0 uri+    case res of+      Just bewit -> do+        let uri' = uri <> "&bewit=" <> bewit+        r <- get (S8.unpack uri')+        putStrLn $ (show $ r ^. responseStatus . statusCode) ++ ": "+          ++ (L8.unpack $ r ^. responseBody)+      Nothing -> putStrLn "Couldn't generate bewit"

@@ -0,0 +1,24 @@+module BewitServer where++import           Data.Text                 (Text)+import           Data.Default              (def)+import           Network.HTTP.Types.Status (status200)+import           Network.Wai+import           Network.Wai.Handler.Warp++import           Common+import           Network.Hawk.Server.Types+import qualified Network.Hawk.Server       as Hawk+import           Network.Hawk.Middleware   (bewitAuth)++serverMain :: IO ()+serverMain = run 8000 (middleware app)++auth :: ClientId -> IO (Either String (Credentials, Text))+auth _ = return $ Right (Credentials sharedKey (HawkAlgo SHA256), "Steve")++middleware :: Middleware+middleware = bewitAuth def auth++app :: Application+app req respond = respond $ responseLBS status200 [] "hello"

@@ -0,0 +1,6 @@+module Common where++import           Network.Hawk.Types++sharedKey :: Key+sharedKey = "werxhqb98rpaxn39848xrunpaw3489ruxnpa98w4rxn"

@@ -0,0 +1,40 @@+module HawkClient where++import           Control.Exception         as E+import           Control.Lens+import           Control.Monad             (void)+import           Data.ByteString           (ByteString)+import qualified Data.ByteString.Lazy.Char8 as L8+import qualified Data.ByteString.Lazy      as BL+import           Data.Either               (isRight)+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.Types.Header (hAuthorization)+import           Network.Wreq++import           Common+import           Network.Hawk+import qualified Network.Hawk.Client       as Hawk++clientMain :: IO ()+clientMain = void $ clientAuth creds uri -- `E.catch` handler+  where+    uri = "http://localhost:8000/resource/1?b=1&a=2"+    creds = Hawk.Credentials "dh37fgj492je" sharedKey (HawkAlgo SHA256)+    handler e@(StatusCodeException s _ _)+      | s ^. statusCode == 401 = putStrLn "Unauthorized"+      | otherwise              = throwIO e++clientAuth :: Hawk.Credentials -> T.Text -> IO Bool+clientAuth creds uri = do+  hdr <- Hawk.header uri "GET" creds Nothing (Just "some-app-data")+  let opts = defaults & header hAuthorization .~ [Hawk.hdrField hdr]+  r <- getWith opts (T.unpack uri)+  let body = r ^. responseBody+  res <- Hawk.authenticate r creds (Hawk.hdrArtifacts hdr) (Just body) Hawk.ServerAuthorizationRequired+  putStrLn $ (show $ r ^. responseStatus . statusCode) ++ ": "+    ++ L8.unpack body+    ++ (if isRight res then " (valid)" else " (invalid)")+  return $ isRight res

@@ -0,0 +1,53 @@+module HawkServer where++import           Control.Monad.IO.Class    (liftIO)+import           Data.ByteString           (ByteString)+import qualified Data.ByteString.Char8     as S8+import qualified Data.ByteString.Lazy      as BL+import qualified Data.ByteString.Lazy.Char8 as L8+import qualified Data.Map                  as M+import           Data.Monoid+import           Data.Monoid+import           Data.Text                 (Text)+import qualified Data.Text                 as T+import           Data.Text.Encoding        (decodeUtf8, encodeUtf8)+import           Network.HTTP.Types.Header+import           Network.HTTP.Types.Status+import           Network.Wai+import           Network.Wai.Handler.Warp++import           Common+import           Network.Hawk.Server.Types+import qualified Network.Hawk.Server       as Hawk++serverMain :: IO ()+serverMain = run 8000 app++auth :: ClientId -> IO (Either String (Credentials, Text))+auth id = return $ Right (Credentials sharedKey (HawkAlgo SHA256), "Steve")++app :: Application+app req respond = do+  let opts = Hawk.defaultAuthReqOpts+  payload <- lazyRequestBody req+  res <- Hawk.authenticateRequest opts auth req (Just payload)+  respond $ case res of+    Right (Hawk.AuthSuccess creds artifacts user) -> do+      let ext = decodeUtf8 <$> shaExt artifacts+      let payload = textPayload $ "Hello " <> user <> maybe "" (" " <>) ext+      let autho = Hawk.header creds artifacts (Just payload)+      responseLBS status200 [payloadCt payload, autho] (payloadData payload)+    Left (Hawk.AuthFailBadRequest e _) -> responseLBS badRequest400 [] (L8.pack e)+    Left (Hawk.AuthFailUnauthorized _ _ _) -> responseLBS unauthorized401 [plain] "Shoosh!"+    Left (Hawk.AuthFailStaleTimeStamp e creds artifacts) -> do+      let autho = Hawk.header creds artifacts Nothing+      responseLBS unauthorized401 [plain, autho] (L8.pack e)++textPayload :: Text -> PayloadInfo+textPayload = PayloadInfo (snd plain) . BL.fromStrict . encodeUtf8++payloadCt :: PayloadInfo -> Header+payloadCt (PayloadInfo ct _) = (hContentType, ct)++plain :: Header+plain = (hContentType, "text/plain")

@@ -0,0 +1,39 @@+module Main where++import Data.List (intercalate)+import System.Environment (getArgs, getProgName)++import qualified HawkClient         as Hawk+import qualified HawkServer         as Hawk+import qualified BewitClient        as Bewit+import qualified BewitServer        as Bewit+import qualified OzClient           as Oz+import qualified OzServer           as Oz++main :: IO ()+main = do+  prog <- getProgName+  args <- getArgs+  case dispatch prog of+    Just act -> act+    Nothing -> case args of+      (arg:_) -> case dispatch arg of+        Just act -> act+        Nothing  -> usage prog+      _ -> usage prog++dispatch :: String -> Maybe (IO ())+dispatch "hawk-server"  = Just Hawk.serverMain+dispatch "hawk-client"  = Just Hawk.clientMain+dispatch "bewit-server" = Just Bewit.serverMain+dispatch "bewit-client" = Just Bewit.clientMain+dispatch "oz-server"    = Just Oz.serverMain+dispatch "oz-client"    = Just Oz.clientMain+dispatch _              = Nothing++usage :: String -> IO ()+usage prog = putStrLn $ "Usage: " ++ prog ++ " [ " ++ progs ++ " ]"+  where+    progs = intercalate " | " [ p ++ "-" ++ c | p <- ps, c <- cs]+    ps = ["hawk", "bewit", "oz"]+    cs = ["client", "server"]

@@ -0,0 +1,4 @@+module OzClient where++clientMain :: IO ()+clientMain = putStrLn "unimplemented"

@@ -0,0 +1,152 @@+{-# LANGUAGE RecordWildCards #-}++module OzServer where++import           Common+import qualified Data.ByteString.Char8    as S8+import qualified Data.ByteString.Lazy     as BL+import           Data.Text.Lazy.Encoding  (encodeUtf8, decodeUtf8)+import qualified Data.Text.Encoding       as ES8 (encodeUtf8, decodeUtf8)+import           Data.CaseInsensitive     (original)+import           Data.List                (find)+import           Data.Monoid              ((<>))+import           Data.Text.Lazy           (Text)+import qualified Data.Text.Lazy           as TL+import           Network.HTTP.Types       (hAuthorization)+import           Network.Wai+import           Control.Monad.IO.Class   (liftIO)+import           Web.Scotty+import           Lucid++import           Network.Oz.Application+import           Network.Oz.Types+import           Network.Oz.Ticket        (rsvp)+import qualified Network.Iron             as Iron++-- fixme: temp+import           Data.Aeson               (Value (..), encode, object, (.=))+import qualified Data.Text                as T+import qualified Network.Hawk.Client      as Hawk++serverMain :: IO ()+serverMain = do+  let opts = (defaultOzServerOpts sharedKey) { ozLoadApp = loadApp }++  let exampleApp = head apps++  scotty 8000 $ do+    middleware $ ifRequest needAuth (ozAuth opts)+    get "/" $ do+      let appUrl = "http://localhost:8000/oz/app" -- fixme: build url from request Host header+      curl <- liftIO $ printCurl exampleApp appUrl Nothing+      lucid $ do+        h1_ "Oz Auth Example"+        p_ "To get an app ticket, try this:"+        pre_ $ toHtml curl++    get "/authorize" $ do+      sealed <- param "ticket"+      res <- liftIO $ openTicket sealed+      lucid $ do+        h1_ "Log in and review grants"+        case res of+          Right t -> do+            p_ $ "Ticket is " <> toHtml (show t)+            case ozTicketGrant t of+              Just grant -> p_ $ "Grant is " <> toHtml grant+              Nothing -> p_ "No grant in ticket"+            if (not . null . ozTicketScope $ t)+              then do+                p_ $ "Requested scope is:"+                ul_ $ mapM_ (li_ . toHtml) (ozTicketScope t)+              else p_ $ "Requested scope is empty"+          Left e -> do+            p_ $ "Couldn't open the ticket: "+            p_ $ toHtml e+        form_ [ method_ "get", action_ "/" ] $ do+          input_ [ type_ "submit", name_ "cancel", value_ "Cancel" ]+        form_ [ method_ "post" ] $ do+          input_ [ type_ "hidden", name_ "ticket", value_ $ ES8.decodeUtf8 sealed ]+          input_ [ type_ "submit", name_ "submit", value_ "Continue" ]+++    post "/authorize" $ do+      sealed <- param "ticket"+      res <- liftIO $ openTicket sealed+      -- fixme: unsealed the ticket, now sealing it again ... something's wrong+      -- need to change it to an rsvp+      r <- case res of+             Right t@OzTicket{..} -> do+               r' <- liftIO $ rsvp ozTicketApp ozTicketGrant sharedKey defaultTicketOpts+               return $ Right (t, r')+             Left e -> return $ Left e++      lucid $ do+        h1_ "Getting rsvp"+        case r of+          Right (t, mrsvp) -> do+            p_ $ "Ticket is " <> toHtml (show t)+            p_ $ "Your rsvp is" <> (toHtml $ show mrsvp)+            case mrsvp of+              Just r -> do+                let url = "/oz/rsvp?ticket=" <> ES8.decodeUtf8 r+                a_ [ href_ url ] "Exchange rsvp for user-specific ticket"+              Nothing -> p_ "failure"+          Left e -> do+            p_ $ "Couldn't open the ticket: "+            p_ $ toHtml e++    -- post "/access" $ do+    --   sealed <- param "ticket"+    --   res <- liftIO $ openTicket sealed+    --   r <- case res of+    --     Right t@OzTicket{..} -> do+    --       r' <- liftIO $ rsvp ozTicketApp ozTicketGrant sharedKey defaultTicketOpts+    --            return $ Right (t, r')+    --          Left e -> return $ Left e++    --   lucid $ do+    --     h1_ "Getting user-ticket"++    get "/protected" $ do+      text $ "this requires a user-ticket"++    -- embed the Oz ticket endpoints+    ozAppScotty opts++lucid :: Html a -> ActionM ()+lucid = html . renderText . page+  where page h = doctypehtml_ $ do+          head_ $ title_ "Oz Auth Example"+          body_ h++needAuth :: Request -> Bool+needAuth req = case reverse (pathInfo req) of+                 ("protected":_) -> True+                 otherwise -> False++openTicket :: S8.ByteString -> IO (Either String OzTicket)+openTicket = Iron.unseal (password sharedKey)+  where password (Hawk.Key p) = Iron.onePassword p++-- | Example apps registry+apps = [OzApp "app123" Nothing False sharedKey (Hawk.HawkAlgo Hawk.SHA256)]++-- | Example lookup of an app by id+loadApp :: OzLoadApp+loadApp aid = return $ case find ((== aid) . ozAppId) apps of+                         Just app -> Right app+                         Nothing -> Left ("ozAppId " ++ show aid ++ " not found")++-- | Shows a curl command line with Hawk Authorization header which+-- can be used to access Oz.+printCurl :: OzApp -> Text -> Maybe Value -> IO Text+printCurl (OzApp aid _ _ key algo) url mdata = do+  auth <- Hawk.headerOz (TL.toStrict url) "POST" creds Nothing Nothing aid Nothing+  let authHeader = decodeUtf8 . BL.fromStrict . fmtHeader . mkHeader $ auth+  return $ "curl -i -X POST " <> dataArg <> "-H 'Content-Type: application/json' -H '" <> authHeader <> "' " <> url+  where+    dataArg = maybe "" (\d -> "--data '" <> decodeUtf8 d <> "'") (fmap encode mdata)+    creds = Hawk.Credentials aid key algo+    fmtHeader (h, v) = original h <> ": " <> v+    mkHeader = (,) hAuthorization . Hawk.hdrField

@@ -0,0 +1,186 @@+name:                hsoz+version:             0.0.0.2+synopsis:            Iron, Hawk, Oz: Web auth protocols+description:++  <<images/iron.png>> &#x20;__&#x20;+  <<images/hawk.png>> &#x20;__&#x20;+  <<images/oz.png>>+  .++  __hsoz__ is a Haskell implementation of the Iron, Hawk, and Oz web+  authentication protocols. These protocols originate from the OAuth2+  standardisation process, but are designed to be simpler to implement+  for the common case of web applications.++  .++  This module is based on the Javascript code and documentation by+  Eran Hammer and others. A fair amount of Hammer's descriptive text+  has been incorporated into this documentation, as well as the cool+  logos.++  .+  == Introduction+  .+  In the words of their principal designer:+  .+  __Iron__ is a cryptographic utility for sealing a JSON object using+  symmetric key encryption with message integrity verification. Or in+  other words, it lets you encrypt an object, send it around (in+  cookies, authentication credentials, etc.), then receive it back and+  decrypt it. The algorithm ensures that the message was not tampered+  with, and also provides a simple mechanism for password rotation.+  .+  __Hawk__ is an HTTP authentication scheme using a message+  authentication code (MAC) algorithm to provide partial HTTP request+  cryptographic verification.+  .+  __Oz__ is a web authorization protocol based on industry best+  practices. Oz combines the Hawk authentication protocol with the+  Iron encryption protocol to provide a simple to use and secure+  solution for granting and authenticating third-party access to an+  API on behalf of a user or an application.+  .+  == Usage+  .+  The top-level "Network.Iron", "Network.Hawk", "Network.Oz" modules+  contain further instructions on their usage. There are also some+  example server and client programs within the+  <https://github.com/rvl/hsoz project git repository>.+++homepage:            https://github.com/rvl/hsoz#readme+license:             BSD3+author:              Rodney Lorrimar+maintainer:          dev@rodney.id.au+copyright:           2016 Rodney Lorrimar+category:            Web, Authentication+build-type:          Simple+extra-doc-files:     images/*.png+cabal-version:       >=1.10++library+  hs-source-dirs:      src+  exposed-modules:     Network.Iron+                     , Network.Hawk+                     , Network.Hawk.Types+                     , Network.Hawk.Server+                     , Network.Hawk.Server.Types+                     , Network.Hawk.Middleware+                     , Network.Hawk.Client+                     , Network.Hawk.Client.Types+                     , Network.Hawk.URI+                     , Network.Oz+                     , Network.Oz.Application+                     , Network.Oz.Client+                     , Network.Oz.Server+                     , Network.Oz.Ticket+                     , Network.Oz.Types+  other-modules:       Network.Iron.Util+                     , Network.Hawk.Algo+                     , Network.Hawk.Common+                     , Network.Hawk.Util+                     , Network.Hawk.Client.HeaderParser+                     , 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+                     , http-client+                     , http-types+                     , lens+                     , memory+                     , mtl+                     , network+                     , scientific+                     , scotty+                     , securemem+                     , text+                     , time+                     , transformers+                     , uri-bytestring+                     , vault+                     , wai+                     , warp+  default-language:    Haskell2010+  default-extensions:  OverloadedStrings++executable hsoz-example+  hs-source-dirs:      example+  main-is:             Main.hs+  other-modules:       Common+                     , HawkServer+                     , HawkClient+                     , BewitServer+                     , BewitClient+                     , OzServer+                     , OzClient+  ghc-options:         -threaded -rtsopts -with-rtsopts=-N+  build-depends:       hsoz+                     , aeson+                     , base+                     , bytestring+                     , case-insensitive+                     , containers+                     , cryptonite+                     , data-default+                     , http-client+                     , http-conduit+                     , http-types+                     , lens+                     , lucid+                     , scotty+                     , text+                     , transformers+                     , uri-bytestring+                     , wai+                     , warp+                     , wreq+  default-language:    Haskell2010+  default-extensions:  OverloadedStrings+  if impl(ghcjs)+    -- this is just because of wreq pulling in unbuildable deps+    buildable:         False++test-suite hsoz-test+  type:                exitcode-stdio-1.0+  hs-source-dirs:      test+  main-is:             Main.hs+  other-modules:       Network.Iron.Tests+                     , Network.Hawk.Tests+                     , Network.Oz.Tests+  build-depends:       base+                     , hsoz+                     , QuickCheck+                     , HUnit+                     , tasty+                     , tasty-hunit+                     , tasty-quickcheck+                     , tasty-golden+                     , text+                     , bytestring+                     , aeson+                     , time+                     , data-default+                     , wai+                     , http-client+                     , http-types+  ghc-options:         -threaded -rtsopts -with-rtsopts=-N+  default-language:    Haskell2010+  default-extensions:  OverloadedStrings++source-repository head+  type:     git+  location: https://github.com/rvl/hsoz

binary file changed (absent → 538 bytes)

binary file changed (absent → 71732 bytes)

binary file changed (absent → 6945 bytes)

binary file changed (absent → 28956 bytes)

binary file changed (absent → 5973 bytes)

binary file changed (absent → 141147 bytes)

@@ -0,0 +1,53 @@+-- |+-- <<images/hawk-logo.png>>+--+-- __Hawk__ is a HTTP authentication scheme using a hash-based message+-- authentication code (HMAC) algorithm to provide partial HTTP+-- request cryptographic verification.+--+-- The message verification covers HTTP method, request URI, host, and+-- optionally the request payload of both requests and responses.+--+-- Similar to the HTTP [Digest access authentication+-- schemes](http://www.ietf.org/rfc/rfc2617.txt), /Hawk/ uses a set of+-- client credentials which include an identifier (e.g. username) and+-- key (e.g. password).+--+-- Likewise, just as with the Digest scheme, the key is never included+-- in authenticated requests. Instead, it is used to calculate a+-- request MAC value which is included in its place.+--+-- Unlike Digest, this scheme is not intended to protect the key+-- itself (the password in Digest) because the client and server must+-- both have access to the key material in the clear.+--+-- The /Hawk/ scheme requires the establishment of a shared symmetric+-- key between the client and the server, which is beyond the scope of+-- this module. Typically, the shared credentials are established via+-- an initial TLS-protected phase or derived from some other shared+-- confidential information available to both the client and the+-- server.+--+-- More information about /Hawk's/ design can be found at its web+-- site: https://github.com/hueniverse/hawk+--+-- == Usage+--+-- To use /Hawk/, depending on your application, use a qualified+-- import of either "Network.Hawk.Server" or "Network.Hawk.Client".+--+-- These modules respectively contain functions to generate+-- @Server-Authorization@/@Authorization@ headers, as well as+-- functions to authenticate requests/responses from the+-- client/server.+--+-- Additionally, there is a small example server and client in the+-- <https://github.com/rvl/hsoz project git repository>.++module Network.Hawk+       ( module Network.Hawk.Types+       ) where++import           Network.Hawk.Client+import           Network.Hawk.Server+import           Network.Hawk.Types

@@ -0,0 +1,66 @@+{-# LANGUAGE DeriveGeneric              #-}+{-# LANGUAGE ExistentialQuantification  #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module Network.Hawk.Algo+  ( HawkAlgo(..)+  , HawkAlgoCls(..)+  , Key(..)+  , SHA1(SHA1)+  , SHA256(SHA256)+  , readHawkAlgo+  ) where++import           Crypto.Hash             (Digest (..), hash)+import           Crypto.Hash.Algorithms  (SHA1 (..), SHA256 (..))+import           Crypto.MAC.HMAC         (HMAC, hmac, hmacGetDigest)+import           Data.ByteArray          (ByteArrayAccess)+import qualified Data.ByteArray.Encoding as B (Base (..), convertToBase)+import           Data.ByteString         (ByteString)+import           Data.Char               (toLower)+import           Data.String             (IsString)+import           GHC.Generics+import           Network.Iron.Util       (b64)++-- fixme: decide whether this should be bytestring or SecureMem, and+-- whether it should be a typeclass.+-- | A user-supplied password or generated key.+newtype Key = Key ByteString deriving (Show, Generic, ByteArrayAccess, IsString)++-- | The class of HMAC algorithms supported by the Hawk+-- protocol. Users of the 'Network.Hawk' module probably won't+-- directly need this.+class HawkAlgoCls a where+  -- | Calculates the hash of a message. The result is encoded in+  -- Base64.+  hawkHash :: a -> ByteString -> ByteString+  -- | Calculates the hash-based MAC of a message. The result is+  -- encoded in Base64.+  hawkMac :: a -> Key -> ByteString -> ByteString++-- | A wrapper data type representing one of the supported HMAC+-- algorithms. Use @HawkAlgo SHA1@ or @HawkAlgo SHA256@.+data HawkAlgo = forall alg . (HawkAlgoCls alg, Show alg) => HawkAlgo alg++instance HawkAlgoCls HawkAlgo where+  hawkHash (HawkAlgo alg) = hawkHash alg+  hawkMac (HawkAlgo alg) = hawkMac alg++instance Show HawkAlgo where+  show (HawkAlgo a) = map toLower (show a)++instance HawkAlgoCls SHA1 where+  hawkHash _ bs = b64 (hash bs :: Digest SHA1)+  hawkMac _ k bs = b64 $ hmacGetDigest (hmac k bs :: HMAC SHA1)++instance HawkAlgoCls SHA256 where+  hawkHash _ bs = b64 (hash bs :: Digest SHA256)+  hawkMac _ k bs = b64 $ hmacGetDigest (hmac k bs :: HMAC SHA256)++-- | Inverse of 'show', for parsing @"algorithm"@ fields in JSON+-- structures.+readHawkAlgo :: String -> Maybe HawkAlgo+readHawkAlgo a = case map toLower a of+                   "sha1"   -> Just (HawkAlgo SHA1)+                   "sha256" -> Just (HawkAlgo SHA256)+                   _        -> Nothing

@@ -0,0 +1,226 @@+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE RecordWildCards           #-}++-- | Functions for making Hawk-authenticated request headers and+-- verifying responses from the server.++module Network.Hawk.Client+       ( header+       , headerOz+       , getBewit+       , authenticate+       , ServerAuthorizationCheck(..)+       , Credentials(..)+       , Header(..)+       , Authorization+       , HeaderArtifacts+       , module Network.Hawk.Types+       ) where++import           Control.Monad.IO.Class    (MonadIO, liftIO)+import           Crypto.Hash+import           Crypto.Random+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.CaseInsensitive      (CI (..))+import qualified Data.Map                  as M+import           Data.Maybe                (catMaybes, fromMaybe)+import           Data.Text                 (Text)+import qualified Data.Text                 as T+import           Data.Text.Encoding        (encodeUtf8)+import           Data.Time.Clock           (NominalDiffTime)+import           Data.Time.Clock.POSIX+import           Network.HTTP.Types.Header (hContentType, hWWWAuthenticate, HeaderName)+import           Network.HTTP.Types.Method (Method)+import           Network.HTTP.Types.URI    (extractPath)+import           Network.HTTP.Client       (Response, responseHeaders)+import           Network.Socket            (PortNumber, SockAddr (..))+import           URI.ByteString            (authorityHost, authorityPort,+                                            hostBS, laxURIParserOptions,+                                            parseURI, portNumber, uriAuthority)++import           Network.Hawk.Common+import           Network.Hawk.Types+import           Network.Hawk.Util+import           Network.Iron.Util+import           Network.Hawk.Client.Types+import           Network.Hawk.Client.HeaderParser++-- | Generates the Hawk authentication header for a request.+header :: Text -- ^ The request URL+       -> Method -- ^ The request method+       -> Credentials -- ^ Credentials used to generate the header+       -> Maybe PayloadInfo -- ^ Optional request payload+       -> Maybe Text -- ^ @ext@ data+       -> IO Header+header url method creds payload ext = headerBase url method creds payload ext Nothing Nothing++-- | Generates the Hawk authentication header for an Oz request. Oz+-- requires another attribute -- the application id. It also has an+-- optional delegated-by attribute, which is the application id of the+-- application the credentials were directly issued to.+headerOz :: Text -> Method -> Credentials -> Maybe PayloadInfo -> Maybe Text+         -> Text -> Maybe Text -> IO Header+headerOz url method creds payload ext app dlg = headerBase url method creds payload ext (Just app) dlg++headerBase :: Text -> Method -> Credentials -> Maybe PayloadInfo -> Maybe Text+           -> Maybe Text -> Maybe Text -> IO Header+headerBase url method creds payload ext app dlg = do+  now <- getPOSIXTime+  nonce <- genNonce+  let hash = calculatePayloadHash (ccAlgorithm creds) <$> payload+  let art = clientHeaderArtifacts now nonce method (encodeUtf8 url) hash (encodeUtf8 <$> ext) app dlg+  let auth = clientHawkAuth creds art+  return $ Header auth art++clientHeaderArtifacts :: POSIXTime -> ByteString -> Method -> ByteString+                      -> Maybe ByteString -> Maybe ByteString+                      -> Maybe Text -> Maybe Text+                      -> HeaderArtifacts+clientHeaderArtifacts now nonce method url hash ext app dlg = case splitUrl url of+  Just (SplitURL host port resource) ->+    HeaderArtifacts now nonce method host port resource hash ext app dlg+  Nothing ->+    HeaderArtifacts now nonce method "" Nothing url hash ext app dlg++clientHawkAuth :: Credentials -> HeaderArtifacts -> ByteString+clientHawkAuth creds arts@HeaderArtifacts{..} = hawkHeaderString (hawkHeaderItems items)+  where+    items = [ ("id", (Just . encodeUtf8 . ccId) creds)+            , ("ts", (Just . S8.pack . show . round) chaTimestamp)+            , ("nonce", Just chaNonce)+            , ("hash", chaHash)+            , ("ext", chaExt)+            , ("mac", Just $ clientMac HawkHeader creds arts)+            , ("app", encodeUtf8 <$> chaApp)+            , ("dlg", encodeUtf8 <$> chaDlg)+            ]++clientMac :: HawkType -> Credentials -> HeaderArtifacts -> ByteString+clientMac h Credentials{..} HeaderArtifacts{..} =+  calculateMac ccAlgorithm ccKey+      chaTimestamp chaNonce chaMethod chaResource chaHost chaPort h++hawkHeaderItems :: [(ByteString, Maybe ByteString)] -> [(ByteString, ByteString)]+hawkHeaderItems = catMaybes . map pull+  where+    pull (k, Just v)  = Just (k, v)+    pull (k, Nothing) = Nothing++splitUrl :: ByteString -> Maybe SplitURL+splitUrl url = SplitURL <$> host <*> pure port <*> path+  where+    p = either (const Nothing) uriAuthority (parseURI laxURIParserOptions url)+    host = fmap (hostBS . authorityHost) p+    port :: Maybe Int+    port = fmap portNumber $ p >>= authorityPort+    path = fmap (const (extractPath url)) p++genNonce :: IO ByteString+genNonce = do+  g <- getSystemDRG+  return $ fst $ withRandomBytes g 10 B64.encode++-- | Whether the client wants to check the received+-- @Server-Authorization@ header depends on the application.+data ServerAuthorizationCheck = ServerAuthorizationNotRequired+                              | ServerAuthorizationRequired+                              deriving Show++-- | Validates the server response.+authenticate :: Response body -> Credentials -> HeaderArtifacts+             -> Maybe BL.ByteString -> ServerAuthorizationCheck+             -> IO (Either String ())+authenticate r creds artifacts payload saCheck = do+  now <- getPOSIXTime+  return $ clientAuthenticate' r creds artifacts payload saCheck now++clientAuthenticate' :: Response body -> Credentials -> HeaderArtifacts+                    -> Maybe BL.ByteString -> ServerAuthorizationCheck+                    -> POSIXTime -> Either String ()+clientAuthenticate' r creds artifacts payload saCheck now = do+  let w = responseHeader hWWWAuthenticate r+  ts <- mapM (checkWwwAuthenticateHeader creds) w+  let sa = responseHeader hServerAuthorization r+  sarh <- checkServerAuthorizationHeader creds artifacts saCheck now sa+  let ct = fromMaybe "" $ responseHeader hContentType r+  let payload' = PayloadInfo ct <$> payload+  case sarh of+    Just sarh' -> checkPayloadHash (ccAlgorithm creds) (sarhHash sarh') payload'+    Nothing -> Right ()++-- fixme: lens version from wreq is better+responseHeader :: HeaderName -> Response body -> Maybe ByteString+responseHeader h = lookup h . responseHeaders++-- | The protocol relies on a clock sync between the client and+-- server. To accomplish this, the server informs the client of its+-- current time when an invalid timestamp is received.+--+-- If an attacker is able to manipulate this information and cause the+-- client to use an incorrect time, it would be able to cause the+-- client to generate authenticated requests using time in the+-- future. Such requests will fail when sent by the client, and will+-- not likely leave a trace on the server (given the common+-- implementation of nonce, if at all enforced). The attacker will+-- then be able to replay the request at the correct time without+-- detection.+--+-- The client must only use the time information provided by the+-- server if:+--+-- * it was delivered over a TLS connection and the server identity+--   has been verified, or+-- * the `tsm` MAC digest calculated using the same client credentials+--   over the timestamp has been verified.+--+-- fixme: implement checks for both of the above conditions+checkWwwAuthenticateHeader :: Credentials -> ByteString -> Either String POSIXTime+checkWwwAuthenticateHeader creds w = do+  WwwAuthenticateHeader{..} <- parseWwwAuthenticateHeader w+  let tsm = calculateTsMac wahTs creds+  if wahTsm `constEqBytes` tsm+    then Right wahTs+    else Left "Invalid server timestamp hash"++calculateTsMac :: POSIXTime -> Credentials -> ByteString+calculateTsMac = undefined  -- fixme: achtung minen++checkServerAuthorizationHeader :: Credentials -> HeaderArtifacts+                                  -> ServerAuthorizationCheck -> POSIXTime+                                  -> Maybe ByteString+                                  -> Either String (Maybe ServerAuthorizationReplyHeader)+checkServerAuthorizationHeader _ _ ServerAuthorizationNotRequired _ Nothing = Right Nothing+checkServerAuthorizationHeader _ _ ServerAuthorizationRequired _ Nothing = Left "Missing Server-Authorization header"+checkServerAuthorizationHeader creds arts _ now (Just sa) = do+  sarh <- parseServerAuthorizationReplyHeader sa+  let mac = clientMac HawkResponse creds arts+  if sarhMac sarh `constEqBytes` mac+    then Right (Just sarh)+    else Left "Bad response mac"++----------------------------------------------------------------------------++-- | Generate a bewit value for a given URI.+getBewit :: Credentials -> NominalDiffTime -> Maybe ByteString -> NominalDiffTime+         -> ByteString -> IO (Maybe ByteString)+-- fixme: ext is a json value i think+-- fixme: javascript version supports deconstructed parsed uri objects+-- fixme: not much point having two time interval arguments?+getBewit creds ttl ext offset uri = do+  exp <- fmap (+ (ttl + offset)) getPOSIXTime+  return $ bewit exp <$> splitUrl uri+  where+    bewit exp = encode . clientMac HawkBewit creds . make+      where+        make (SplitURL host port resource) =+          HeaderArtifacts exp "" "GET" host port resource Nothing ext Nothing Nothing+        encode = b64url . S8.intercalate "\\" . parts+        parts mac = [ encodeUtf8 . ccId $ creds+                    , S8.pack . show . round $ exp+                    , mac, fromMaybe "" ext ]

@@ -0,0 +1,52 @@+module Network.Hawk.Client.HeaderParser+  ( parseWwwAuthenticateHeader+  , parseServerAuthorizationReplyHeader+  , WwwAuthenticateHeader(..)+  , ServerAuthorizationReplyHeader(..)+  ) where++import Data.ByteString (ByteString)+import Data.Time.Clock.POSIX     (POSIXTime)+import Network.Hawk.Client.Types+import Control.Monad (join)++import Network.Hawk.Util++-- | Represents the `WWW-Authenticate` header which the server uses to+-- respond when the client isn't authenticated.+data WwwAuthenticateHeader = WwwAuthenticateHeader+                             { wahTs    :: POSIXTime  -- ^ server's timestamp+                             , wahTsm   :: ByteString -- ^ timestamp mac+                             , wahError :: ByteString+                             } deriving Show++-- | Represents the `Server-Authorization` header which the server+-- sends back to the client.+data ServerAuthorizationReplyHeader = ServerAuthorizationReplyHeader+                                      { sarhMac  :: ByteString+                                      , sarhHash :: Maybe ByteString -- ^ optional payload hash+                                      , sarhExt  :: Maybe ByteString+                                      } deriving Show++parseWwwAuthenticateHeader :: ByteString -> Either String WwwAuthenticateHeader+parseWwwAuthenticateHeader = fmap snd . parseHeader wwwKeys wwwAuthHeader++parseServerAuthorizationReplyHeader :: ByteString -> Either String ServerAuthorizationReplyHeader+parseServerAuthorizationReplyHeader = fmap snd . parseHeader serverKeys serverAuthReplyHeader++wwwKeys = ["tsm", "ts", "error"]+serverKeys = ["mac", "ext", "hash"]++wwwAuthHeader :: AuthAttrs -> Either String WwwAuthenticateHeader+wwwAuthHeader m = do+  credTs <- join (readTs <$> authAttr m "ts")+  credTsm <- authAttr m "tsm"+  credError <- authAttr m "error"+  return $ WwwAuthenticateHeader credTs credTsm credError++serverAuthReplyHeader :: AuthAttrs -> Either String ServerAuthorizationReplyHeader+serverAuthReplyHeader m = do+  mac <- authAttr m "mac"+  let hash = authAttrMaybe m "hash"+  let ext = authAttrMaybe m "ext"+  return $ ServerAuthorizationReplyHeader mac hash ext

@@ -0,0 +1,50 @@+{-# LANGUAGE DeriveGeneric             #-}++-- | Consider this module to be internal, and don't import directly.++module Network.Hawk.Client.Types where++import           Data.Text (Text)+import           Data.ByteString (ByteString)+import           Data.Time.Clock.POSIX (POSIXTime)+import           GHC.Generics+import           Network.HTTP.Types.Method (Method)++import           Network.Hawk.Common+import           Network.Hawk.Types++-- | ID and key used for encrypting Hawk @Authorization@ header.+data Credentials = Credentials+  { ccId        :: ClientId+  , ccKey       :: Key+  , ccAlgorithm :: HawkAlgo+  } deriving (Show, Generic)++-- | Struct for attributes which will be encoded in the Hawk+-- @Authorization@ header. The term "artifacts" comes from the+-- original Javascript implementation of Hawk.+data HeaderArtifacts = HeaderArtifacts+  { chaTimestamp :: POSIXTime+  , chaNonce     :: ByteString+  , chaMethod    :: Method+  , chaHost      :: ByteString+  , chaPort      :: Maybe Int+  , chaResource  :: ByteString+  , chaHash      :: Maybe ByteString+  , chaExt       :: Maybe ByteString -- fixme: this should be json value+  , chaApp       :: Maybe Text -- ^ app id, for oz+  , chaDlg       :: Maybe Text -- ^ delegated-by app id, for oz+  } deriving Show++-- | The result of Hawk header generation.+data Header = Header+  { hdrField     :: Authorization  -- ^ Value of @Authorization@ header.+  , hdrArtifacts :: HeaderArtifacts  -- ^ Not sure if this is needed by users.+  } deriving (Show, Generic)+++data SplitURL = SplitURL+  { urlHost :: ByteString+  , urlPort :: Maybe Int+  , urlPath :: ByteString+  } deriving (Show, Generic)

@@ -0,0 +1,124 @@+{-# LANGUAGE ExistentialQuantification #-}++module Network.Hawk.Common+       ( calculateMac+       , escapeHeaderAttribute+       , hawkHeaderString+       , calculatePayloadHash+       , checkPayloadHash+       , checkPayloadHashMaybe+       , hServerAuthorization+       , HawkType(..)+       , Authorization+       ) where++import           Crypto.Hash.Algorithms    (HashAlgorithm, SHA1 (..),+                                            SHA256 (..))+import           Data.ByteString           (ByteString)+import qualified Data.ByteString           as BS+import           Data.ByteString.Builder   (byteString, charUtf8,+                                            toLazyByteString)+import qualified Data.ByteString.Char8     as S8+import qualified Data.ByteString.Lazy      as BL+import           Data.Byteable             (constEqBytes)+import           Data.Char                 (toLower, toUpper)+import           Data.List                 (intercalate)+import           Data.Monoid               ((<>))+import           Data.Time.Clock.POSIX+import           Network.HTTP.Types.Header (HeaderName)+import           Network.HTTP.Types.Method (Method)++import           Network.Hawk.Types++data HawkType = HawkHeader | HawkBewit | HawkResponse+              deriving (Show, Eq)++-- | The value of an @Authorization@ header.+type Authorization = ByteString++-- | Generates a @hawk.1.@ string with the given attributes,+-- calculates its HMAC, and returns the Base64 encoded hash.+calculateMac :: HawkAlgoCls a => a -> Key+             -> POSIXTime -> ByteString -> Method+             -> ByteString -> ByteString -> Maybe Int+             -> HawkType -> ByteString+calculateMac a key ts nonce method path host port hawkType = hawkMac a key str+  where+    str = hawk1String hawkType ts nonce method path host port++-- This would be the same as Hoek.escapeHeaderAttribute, which+-- replaces double quotes and backslashes so that the string can be+-- put in a HTTP header. I'm not sure if it's needed if WAI already+-- quotes header values.+escapeHeaderAttribute :: ByteString -> ByteString+escapeHeaderAttribute = id++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)+    payloadInfo = PayloadInfo ct payload+checkPayload Nothing algo ct payload = Left "Missing required payload hash"++checkPayloadHashMaybe :: HawkAlgoCls a => a -> Maybe ByteString -> Maybe PayloadInfo -> Maybe Bool+checkPayloadHashMaybe _    _           Nothing        = Just True+checkPayloadHashMaybe _    Nothing     (Just _)       = Nothing+checkPayloadHashMaybe algo (Just hash) (Just payload) = Just (hash == calculatePayloadHash algo payload)++checkPayloadHash :: HawkAlgoCls a => a -> Maybe ByteString -> Maybe PayloadInfo -> Either String ()+checkPayloadHash algo hash payload = case checkPayloadHashMaybe algo hash payload of+  Nothing    -> Left "Missing response hash attribute"+  Just False -> Left "Bad response payload mac"+  Just True  -> Right ()++hawk1String :: HawkType -> POSIXTime -> ByteString -> Method -> ByteString -> ByteString -> Maybe Int -> ByteString+-- corresponds to generateNormalizedString in crypto.js+-- fixme: ext and payload hash+hawk1String t ts nonce method resource host port = newlines $+  [ "hawk.1." <> hawkType t+  , (S8.pack . show . round) ts+  , nonce+  , S8.map toUpper method+  , resource+  , S8.map toLower host+  , maybe "" (S8.pack . show) port+  , payloadHash+  ] ++ ext+  where+      ext = []+      payloadHash = ""++hawk1Payload :: PayloadInfo -> ByteString+hawk1Payload (PayloadInfo contentType body) = newlines [ "hawk.1.payload"+                                                       , contentType+                                                       , BL.toStrict body ]++newlines :: [ByteString] -> ByteString+newlines lines = BS.intercalate (S8.singleton '\n') (lines ++ [""])++hawkType :: HawkType -> ByteString+hawkType HawkHeader   = "header"+hawkType HawkBewit    = "bewit"+hawkType HawkResponse = "response"++hawk1Header = hawk1String HawkHeader++-- Generates an @Authorization@ header string of the form:+-- Hawk id="app123", ts="1476130687", nonce="+olvVyT7i8dqkA==",+--   mac="xG9KhUQXjCSWbqNbRI41tI19+fG0upsuDoVbNpt8+K0=", app="app123"+hawkHeaderString :: [(ByteString, ByteString)] -> ByteString+hawkHeaderString items = BL.toStrict $ toLazyByteString bld+  where+    bld = byteString "Hawk " <> mconcat (intercalate comma $ foldMap q items)+    comma = [byteString ", "]+    q (k, v) = [[byteString k, byteString "=\"", byteString v, byteString "\""]]++calculatePayloadHash :: HawkAlgoCls a => a -> PayloadInfo -> ByteString+-- fixme: maybe convert payload to strict further up the chain, or+-- feed chunks to the hasher+calculatePayloadHash algo payload = hawkHash algo (hawk1Payload payload)++-- | The name of the authorization header which the server provides to+-- the client.+hServerAuthorization :: HeaderName+hServerAuthorization = "Server-Authorization"

@@ -0,0 +1,67 @@+-- | Middlewares which can be used to add Hawk authentication to a+-- "Network.Wai" 'Network.Wai.Application'.+--+-- The authentication result is stored in a 'Data.Vault.Lazy.Vault'.+--+-- Note that 'Network.Wai.ifRequest' can be used to conditionally+-- apply these middlewares.++module Network.Hawk.Middleware+  ( hawkAuth+  , bewitAuth+  , VerifyPayload(..)+  ) where++import Data.Text (Text)+import Data.ByteString (ByteString)+import qualified Data.ByteString.Lazy.Char8 as L8+import Network.Wai+import           Network.HTTP.Types        (badRequest400, unauthorized401)+import           Network.HTTP.Types.Header (Header, hContentType, hWWWAuthenticate)++import qualified Data.Vault.Lazy as V++import qualified Network.Hawk.Server as Hawk++-- | Whether the middleware should verify the payload hash by reading+-- the entire request body. 'Network.Hawk.Server.authenticatePayload'+-- can be used to verify the payload at a later stage.+data VerifyPayload = DontVerifyPayload -- ^ Ignore payload hash.+                   | VerifyPayload -- ^ Read request body and check payload hash.+  deriving (Show, Eq)++-- | Authenticates requests with Hawk according to the provided+-- options and credentials.+hawkAuth :: Hawk.AuthReqOpts -> VerifyPayload -> Hawk.CredentialsFunc IO t -> Middleware+hawkAuth opts vp c = genHawkAuth $ \req -> do+  payload <- case vp of+               DontVerifyPayload -> pure Nothing+               VerifyPayload -> Just <$> lazyRequestBody req+  Hawk.authenticateRequest opts c req payload++-- | Authenticates @GET@ requests with the Hawk bewit scheme,+-- according to the provided options and credentials.+bewitAuth :: Hawk.AuthReqOpts -> Hawk.CredentialsFunc IO t -> Middleware+bewitAuth opts creds = genHawkAuth $ Hawk.authenticateBewit opts creds++genHawkAuth :: (Request -> IO (Hawk.AuthResult t)) -> Application -> Application+genHawkAuth auth app req respond = do+  k <- V.newKey+  res <- auth req+  case res of+    Right s -> do+      let vault' = V.insert k s (vault req)+          req' = req { vault = vault' }+      app req' respond+    Left f -> respond $ case f of+      Hawk.AuthFailBadRequest e _ ->+        responseLBS badRequest400 [plain, wwwAuthHawk] (L8.pack e)+      Hawk.AuthFailUnauthorized e _ _ ->+        responseLBS unauthorized401 [plain, wwwAuthHawk] (L8.pack e)+      Hawk.AuthFailStaleTimeStamp e creds artifacts ->+        let autho = Hawk.header creds artifacts Nothing+        in responseLBS unauthorized401 [plain, autho] (L8.pack e)++plain, wwwAuthHawk :: Header+plain = (hContentType, "text/plain")+wwwAuthHawk = (hWWWAuthenticate, "Hawk")

@@ -0,0 +1,330 @@+{-# LANGUAGE RecordWildCards #-}++-- | These are functions for checking authenticated requests and+-- sending authenticated responses.++module Network.Hawk.Server+       ( authenticateRequest+       , authenticate+       , authenticateBewit+       , authenticatePayload+       , HawkReq(..)+       , header+       , defaultAuthReqOpts+       , defaultAuthOpts+       , AuthReqOpts(..)+       , AuthOpts(..)+       , module Network.Hawk.Server.Types+       ) where++import           Control.Applicative       ((<|>))+import           Control.Monad             (join)+import           Control.Monad.IO.Class    (MonadIO, liftIO)+import           Data.ByteString           (ByteString)+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.CaseInsensitive      (CI (..))+import           Data.Maybe                (catMaybes, fromMaybe)+import           Data.Monoid               ((<>))+import           Data.Text                 (Text)+import qualified Data.Text                 as T+import           Data.Text.Encoding        (decodeUtf8, decodeUtf8')+import           Control.Error.Safe        (rightMay)+import           Data.Default              (Default(..))+import           Data.Time.Clock           (NominalDiffTime)+import           Data.Time.Clock.POSIX+import           Network.HTTP.Types.Header (Header, hAuthorization,+                                            hContentType)+import           Network.HTTP.Types.Method (Method, methodGet, methodPost)+import           Network.HTTP.Types.URI    (renderQuery)+import           Network.Wai               (Request, rawPathInfo,+                                            rawQueryString, queryString,+                                            remoteHost, requestMethod,+                                            requestHeaderHost, requestHeaders)++import           Network.Hawk.Common+import           Network.Hawk.Server.Types+import           Network.Hawk.Util+import           Network.Iron.Util         (b64urldec, justRight, mapLeft)++-- | Bundle of parameters for 'authenticateRequest'. Provides+-- information about what the public URL of the server would be. If+-- the application is served from a HTTP reverse proxy, then the+-- @Host@ header might have a different name, or the @hostname:port@+-- might need to be overridden.+data AuthReqOpts = AuthReqOpts+  { saHostHeaderName :: Maybe (CI ByteString) -- ^ Alternate name for @Host@ header+  , saHost           :: Maybe ByteString -- ^ Overrides the URL host+  , saPort           :: Maybe ByteString -- ^ Overrides the URL port+  , saBewitParam     :: ByteString -- ^ Query parameter for bewit authentication+  , saOpts           :: AuthOpts  -- ^ Parameters for 'authenticate'+  }++-- | Bundle of parameters for 'authenticate'.+data AuthOpts = AuthOpts+  { saCheckNonce          :: NonceFunc+  , saTimestampSkew       :: NominalDiffTime+  , saIronLocaltimeOffset :: NominalDiffTime -- fixme: check this is still needed+  }++-- | Default parameters for 'authenticateRequest'.+defaultAuthReqOpts = AuthReqOpts Nothing Nothing Nothing "bewit" defaultAuthOpts++defaultAuthOpts = AuthOpts (\x t n -> True) 60 0++instance Default AuthReqOpts where+  def = defaultAuthReqOpts++instance Default AuthOpts where+  def = defaultAuthOpts++-- | Checks the @Authorization@ header of a 'Network.Wai.Request' and+-- (optionally) a payload. The header will be parsed and verified with+-- the credentials supplied.+--+-- If the request payload is provided, it will be verified. If a+-- payload is not supplied, it can be verified later with+-- 'authenticatePayload'.+authenticateRequest :: MonadIO m => AuthReqOpts -> CredentialsFunc m t+                    -> Request -> Maybe BL.ByteString -> m (AuthResult t)+authenticateRequest opts creds req body = do+  let hreq = hawkReq opts req body+  if BS.null (hrqAuthorization hreq)+    then return $ Left (AuthFailBadRequest "Missing Authorization header" Nothing)+    else authenticate (saOpts opts) creds hreq++authenticateBewit' opts (creds, t) req bewit+  | mac `constEqBytes` (bewitMac bewit) = Right (AuthSuccess creds arts t)+  | otherwise = Left (AuthFailUnauthorized "Bad mac" (Just creds) (Just arts))+  where+    arts = bewitArtifacts req bewit+    mac = serverMac creds arts HawkBewit++bewitArtifacts :: HawkReq -> Bewit -> HeaderArtifacts+bewitArtifacts HawkReq{..} Bewit{..} =+  HeaderArtifacts hrqMethod hrqHost hrqPort hrqBewitlessUrl+    "" bewitExp "" "" Nothing (Just bewitExt) Nothing Nothing++-- | Checks the @Authorization@ header of a request according to the+-- "bewit" scheme. See "Network.Hawk.URI" for a description of that+-- scheme.+authenticateBewit :: MonadIO m => AuthReqOpts -> CredentialsFunc m t+                  -> Request -> m (AuthResult t)+authenticateBewit opts getCreds req = do+  now <- liftIO getPOSIXTime+  case checkBewit hrq now of+    Right bewit -> do+      mcreds <- mapLeft unauthorized <$> getCreds (bewitId bewit)+      return $ case mcreds of+        Right creds -> authenticateBewit' opts creds hrq bewit+        Left e -> undefined+    Left e -> return (Left e)++  where+    hrq = hawkReq opts req Nothing+    checkBewit :: HawkReq -> POSIXTime -> Either AuthFail Bewit+    checkBewit HawkReq{..} now = do+      encBewit <- checkEmpty hrqBewit+      checkMethod hrqMethod+      checkHeader hrqAuthorization+      bewit <- mapLeft unauthorized $ decodeBewit encBewit+      checkAttrs bewit+      checkExpiry bewit now+      return bewit++    -- need a bewit in the query string+    checkEmpty (Just "") = Left (unauthorized "Empty bewit")+    checkEmpty Nothing   = Left (unauthorized "")+    checkEmpty (Just b)  = Right b+    -- bewit is not intended for PUT, POST, DELETE, etc+    checkMethod m = if m == "GET" || m == "HEAD" then Right ()+                    else Left (unauthorized "Invalid method")+    -- client should use either holder-of-key or bewit, not both+    checkHeader h = if BS.null h then Right ()+                    else Left (badRequest "Multiple authentications")+    -- disallow empty attributes+    checkAttrs (Bewit i _ m _) = if T.null i || BS.null m+                                 then Left (badRequest "Missing bewit attributes")+                                 else Right ()+    checkExpiry b now = if now < bewitExp b then Right ()+                        else Left (AuthFailUnauthorized ("Access expired " ++ show (bewitExp b)) Nothing Nothing) -- fixme: include hrqBewit+    unauthorized e = AuthFailUnauthorized e Nothing Nothing+    badRequest e = AuthFailBadRequest e Nothing+++hawkReq :: AuthReqOpts -> Request -> Maybe BL.ByteString -> HawkReq+hawkReq AuthReqOpts{..} req body = HawkReq+  { hrqMethod = requestMethod req+  , hrqUrl = baseUrl <> rawQueryString req+  , hrqHost = justString (saHost <|> host)+  , hrqPort = port+  , hrqAuthorization = justString $ lookup hAuthorization $ requestHeaders req+  , hrqPayload = PayloadInfo ct <$> body -- if provided, the payload hash will be checked+  , hrqBewit = fmap justString <$> lookup saBewitParam $ queryString req+  , hrqBewitlessUrl = baseUrl <> bewitQueryString+  }+  where+    baseUrl = rawPathInfo req  -- fixme: path /= url+    hostHdr = maybe (requestHeaderHost req) (flip lookup (requestHeaders req)) saHostHeaderName+    (host, port) = case parseHostnamePort <$> hostHdr of+      Nothing             -> (Nothing, Nothing)+      (Just ("", p))      -> (Nothing, p)+      (Just (h, Just p))  -> (Just h, Just p)+      (Just (h, Nothing)) -> (Just h, Nothing)+    ct = justString $ lookup hContentType $ requestHeaders req+    justString = fromMaybe ""+    bewitQueryString = renderQuery True $ removeBewit (queryString req)+    removeBewit = filter ((/= saBewitParam) . fst)++-- | Checks the @Authorization@ header of a generic request. The+-- header will be parsed and verified with the credentials+-- supplied.+--+-- If a payload is provided, it will be verified. If the payload is+-- not supplied, it can be verified later with 'authenticatePayload'.+authenticate :: MonadIO m => AuthOpts -> CredentialsFunc m t -> HawkReq -> m (AuthResult t)+authenticate opts getCreds req@HawkReq{..} = do+  now <- liftIO getPOSIXTime+  case parseServerAuthorizationHeader hrqAuthorization of+    Right sah@AuthorizationHeader{..} -> do+      creds <- getCreds sahId+      return $ case creds of+        Right creds' -> authenticate' now opts creds' req sah+        Left e -> Left (AuthFailUnauthorized e Nothing (Just (headerArtifacts req sah)))+    Left err -> return $ Left err++authenticate' :: POSIXTime -> AuthOpts -> (Credentials, t)+              -> HawkReq -> AuthorizationHeader -> AuthResult t+authenticate' now opts (creds, t) hrq@HawkReq{..} sah@AuthorizationHeader{..} = do+  let arts = headerArtifacts hrq sah+  let doCheck = authResult creds arts t+  let mac = serverMac creds arts HawkHeader+  if mac `constEqBytes` sahMac then do+    doCheck $ checkPayloadHash (scAlgorithm creds) sahHash hrqPayload+    doCheck $ checkNonce (saCheckNonce opts) (scKey creds) sahNonce sahTs+    doCheck $ checkExpiration now (saTimestampSkew opts) sahTs+    doCheck $ Right ()+    else Left (AuthFailUnauthorized "Bad mac" (Just creds) (Just arts))++-- | Maps auth status into the more detailed success/failure type+authResult :: Credentials -> HeaderArtifacts -> t+           -> Either String a -> Either AuthFail (AuthSuccess t)+authResult c a t (Right _) = Right (AuthSuccess c a t)+authResult c a _ (Left e)  = Left (AuthFailUnauthorized e (Just c) (Just a))++-- | Constructs artifacts bundle out of the request.+headerArtifacts :: HawkReq -> AuthorizationHeader -> HeaderArtifacts+headerArtifacts HawkReq{..} AuthorizationHeader{..} =+  HeaderArtifacts hrqMethod hrqHost hrqPort hrqUrl+    sahId sahTs sahNonce sahMac sahHash sahExt (fmap decodeUtf8 sahApp) sahDlg++-- | Verifies the payload hash as a separate step after other things+-- have been check. This is useful when the request body is streamed+-- for example.+authenticatePayload :: AuthSuccess t -> PayloadInfo -> Either String ()+authenticatePayload (AuthSuccess c a _) p =+  checkPayloadHash (scAlgorithm c) (shaHash a) (Just p)+++-- | Generates a suitable @Server-Authorization@ header to send back+-- to the client. Credentials and artifacts would be provided by a+-- previous call to 'authenticateRequest' (or 'authenticate').+--+-- If a payload is supplied, its hash will be included in the header.+header :: Credentials -> HeaderArtifacts -> Maybe PayloadInfo -> Header+header creds arts payload = (hServerAuthorization, hawkHeaderString (catMaybes parts))+  where+    parts :: [Maybe (ByteString, ByteString)]+    parts = [ Just ("mac", mac)+            , fmap ((,) "hash") hash+            , fmap ((,) "ext") ext]+    hash = calculatePayloadHash (scAlgorithm creds) <$> payload+    ext = escapeHeaderAttribute <$> (shaExt arts)+    mac = serverMac creds arts HawkResponse++serverMac :: Credentials -> HeaderArtifacts -> HawkType -> ByteString+serverMac Credentials{..} HeaderArtifacts{..} =+  calculateMac scAlgorithm scKey+    shaTimestamp shaNonce shaMethod shaResource shaHost shaPort++-- | User-supplied nonce validation function.+type NonceFunc = Key -> POSIXTime -> Nonce -> Bool+type Nonce = ByteString++checkNonce :: NonceFunc -> Key -> Nonce -> POSIXTime -> Either String ()+checkNonce nonceFunc key nonce ts = if nonceFunc key ts nonce then Right ()+                                    else Left "Invalid nonce"++checkExpiration :: POSIXTime -> NominalDiffTime -> POSIXTime -> Either String ()+checkExpiration now skew ts = if abs (ts - now) <= skew then Right ()+                              else Left "Expired seal"++----------------------------------------------------------------------------+-- Authorization header parsing++-- | Represents the `Authorization` header which the client+-- sends to the server.+data AuthorizationHeader = AuthorizationHeader+  { sahId    :: Text+  , sahTs    :: POSIXTime+  , sahNonce :: ByteString+  , sahMac   :: ByteString+  , sahHash  :: Maybe ByteString -- ^ optional payload hash+  , sahExt   :: Maybe ByteString -- ^ optional extra data to verify+  , sahApp   :: Maybe ByteString -- ^ optional oz application id+  , sahDlg   :: Maybe ByteString -- ^ optional oz delegate+  } deriving Show++parseServerAuthorizationHeader :: ByteString -> AuthResult' AuthorizationHeader+parseServerAuthorizationHeader = parseHeaderServer allKeys serverAuthHeader++allKeys = ["id", "ts", "nonce", "hash", "ext", "mac", "app", "dlg"]++parseHeaderServer :: [ByteString] -> (AuthAttrs -> Either String hdr) -> ByteString -> AuthResult' hdr+parseHeaderServer keys hdr = parseResult . parseHeader keys hdr+  where+    -- Map parse failures to the detailed error statuses+    parseResult :: Either String (AuthScheme, hdr) -> AuthResult' hdr+    parseResult (Right ("Hawk", h)) = Right h+    parseResult (Right _)           = Left (AuthFailUnauthorized "Hawk" Nothing Nothing)+    parseResult (Left e)            = Left (AuthFailBadRequest e Nothing)++serverAuthHeader :: AuthAttrs -> Either String AuthorizationHeader+serverAuthHeader m = do+  id <- decodeUtf8 <$> authAttr m "id"+  ts <- join (readTs <$> authAttr m "ts")+  nonce <- authAttr m "nonce"+  mac <- authAttr m "mac"+  return $ AuthorizationHeader id ts nonce mac+    (authAttrMaybe m "hash") (authAttrMaybe m "ext")+    (authAttrMaybe m "app") (authAttrMaybe m "dlg")++----------------------------------------------------------------------------+-- Bewit parsing++data Bewit = Bewit+             { bewitId  :: Text+             , bewitExp :: POSIXTime+             , bewitMac :: ByteString+             , bewitExt :: ByteString+             } deriving Show++-- | Parses an bewit query string value in the format+-- @id\exp\mac\ext@. The delimiter @'\'@ is used as because it is a+-- reserved header attribute character.+decodeBewit :: ByteString -> Either String Bewit+decodeBewit s = decode s >>= fourParts >>= bewit+  where+    decode = fmap (S8.split '\\') . fixMsg . b64urldec+    fourParts [a, b, c, d] = Right (a, b, c, d)+    fourParts _            = Left "Invalid bewit structure"+    bewit = justRight "Invalid bewit structure" . bewit'+    bewit' (id, exp, mac, ext) = Bewit <$> decodeId id+                                 <*> readTsMaybe exp+                                 <*> pure mac <*> pure ext+    fixMsg = mapLeft (const "Invalid bewit encoding")+    decodeId = rightMay . decodeUtf8'++----------------------------------------------------------------------------

@@ -0,0 +1,90 @@+{-# LANGUAGE DeriveGeneric              #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module Network.Hawk.Server.Types+  ( AuthResult+  , AuthResult'(..)+  , AuthFail(..)+  , AuthSuccess(..)+  , Credentials(..)+  , HeaderArtifacts(..)+  , CredentialsFunc+  , HawkReq(..)+  , module Network.Hawk.Types+  ) where++import Data.ByteString           (ByteString)+import Data.Text                 (Text)+import Data.Time.Clock.POSIX     (POSIXTime)+import Network.HTTP.Types.Method (Method)+import GHC.Generics+import Data.Default+import Network.Hawk.Types++-- | The end result of authentication.+type AuthResult t = AuthResult' (AuthSuccess t)+-- | An intermediate result of authentication.+type AuthResult' r = Either AuthFail r++-- | Authentication can fail in multiple ways. This type includes the+-- information necessary to generate a suitable response for the+-- client. In the case of a stale timestamp, the client may try+-- another authenticated request.+data AuthFail = AuthFailBadRequest String (Maybe HeaderArtifacts)+              | AuthFailUnauthorized String (Maybe Credentials) (Maybe HeaderArtifacts)+              | AuthFailStaleTimeStamp String Credentials HeaderArtifacts+              deriving Show++-- | Successful authentication produces a set of credentials and+-- "artifacts". Also included in the result is the result of+-- 'CredentialsFunc'.+data AuthSuccess t = AuthSuccess Credentials HeaderArtifacts t++instance Show t => Show (AuthSuccess t)++----------------------------------------------------------------------------++-- | A package of values containing the attributes of a HTTP request+-- which are relevant to Hawk authentication.+data HawkReq = HawkReq+  { hrqMethod        :: Method+  , hrqUrl           :: ByteString+  , hrqHost          :: ByteString+  , hrqPort          :: Maybe Int+  , hrqAuthorization :: ByteString+  , hrqPayload       :: Maybe PayloadInfo+  , hrqBewit         :: Maybe ByteString+  , hrqBewitlessUrl  :: ByteString+  } deriving Show++instance Default HawkReq where+  def = HawkReq "GET" "/" "localhost" Nothing "" Nothing Nothing ""++-- | The set of data the server requires for key-based hash+-- verification of artifacts.+data Credentials = Credentials+  { scKey       :: Key -- ^ Key+  , scAlgorithm :: HawkAlgo -- ^ HMAC+  } deriving (Show, Generic)++-- | HeaderArtifacts are the attributes which are included in the+-- verification. The terminology (and spelling) come from the original+-- Javascript implementation of Hawk.+data HeaderArtifacts = HeaderArtifacts+  { shaMethod    :: Method+  , shaHost      :: ByteString+  , shaPort      :: Maybe Int+  , shaResource  :: ByteString+  , shaId        :: ClientId+  , shaTimestamp :: POSIXTime+  , shaNonce     :: ByteString+  , shaMac       :: ByteString -- ^ Entire header hash+  , shaHash      :: Maybe ByteString -- ^ Payload hash+  , shaExt       :: Maybe ByteString+  , shaApp       :: Maybe Text+  , shaDlg       :: Maybe ByteString+  } deriving Show++-- | A user-supplied callback to get credentials from a client+-- identifier.+type CredentialsFunc m t = ClientId -> m (Either String (Credentials, t))

@@ -0,0 +1,31 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module Network.Hawk.Types+       ( ClientId+       , Key(..)+       , ContentType+       , PayloadInfo(..)+       , module Network.Hawk.Algo+       ) where++import           Control.Applicative+import           Data.ByteString           (ByteString)+import qualified Data.ByteString.Lazy      as BL+import           Data.Text                 (Text)++import           Network.Hawk.Algo++-- | Identifies a particular client so that their credentials can be+-- looked up.+type ClientId = Text++----------------------------------------------------------------------------++-- | Value of @Content-Type@ HTTP headers.+type ContentType = ByteString -- fixme: CI ByteString++-- | Payload data and content type bundled up for convenience.+data PayloadInfo = PayloadInfo+                   { payloadContentType :: ContentType+                   , payloadData        :: BL.ByteString+                   } deriving Show

@@ -0,0 +1,46 @@+-- | == Single URI Authorization+--+-- There are cases in which limited and short-term access to a+-- protected resource is granted to a third party which does not have+-- access to the shared credentials. For example, displaying a+-- protected image on a web page accessed by anyone. __Hawk__ provides+-- limited support for such URIs in the form of a /bewit/ — a URI+-- query parameter appended to the request URI which contains the+-- necessary credentials to authenticate the request.+--+-- Because of the significant security risks involved in issuing such+-- access, bewit usage is purposely limited only to GET requests and+-- for a finite period of time. Both the client and server can issue+-- bewit credentials, however, the server should not use the same+-- credentials as the client to maintain clear traceability as to who+-- issued which credentials.+--+-- In order to simplify implementation, bewit credentials do not+-- support single-use policy and can be replayed multiple times within+-- the granted access timeframe.+--+-- This module collects the URI authorization functions in a single+-- module, to mirror the @Hawk.uri@ module of the javascript+-- implementation.++module Network.Hawk.URI+  ( authenticate+  , middleware+  , getBewit+  ) where++import           Control.Monad.IO.Class    (MonadIO)+import           Network.Wai               (Request)++import Network.Hawk.Types+import Network.Hawk.Server (authenticateBewit, CredentialsFunc, AuthReqOpts, AuthResult)+import Network.Hawk.Middleware (bewitAuth)+import Network.Hawk.Client (getBewit)++-- | See 'Network.Hawk.Server.authenticateBewit'.+authenticate :: MonadIO m => AuthReqOpts -> CredentialsFunc m t+             -> Request -> m (AuthResult t)+authenticate = authenticateBewit++-- | See 'Network.Hawk.Middleware.bewitAuth'.+middleware = bewitAuth

@@ -0,0 +1,97 @@+module Network.Hawk.Util+       ( parseHostnamePort+       , parseHeader+       , AuthAttrs+       , AuthScheme+       , authAttr+       , authAttrMaybe+       , readTs+       , readTsMaybe+       ) where++import           Control.Applicative              ((<|>))+import           Data.Attoparsec.ByteString.Char8+import           Data.ByteString                  (ByteString)+import qualified Data.ByteString.Char8            as S8+import           Data.CaseInsensitive             (CI)+import qualified Data.CaseInsensitive             as CI+import qualified Data.Map                         as M+import           Data.Monoid                      ((<>))+import           Data.Text                        (Text)+import           Data.Text.Encoding               (decodeUtf8)+import           Data.Time.Clock.POSIX++import           Network.Hawk.Common+import           Network.Hawk.Types++parseHeader :: [ByteString] -> (AuthAttrs -> Either String hdr) -> ByteString -> Either String (AuthScheme, hdr)+parseHeader keys hdr = parseOnly (hawkAuthParser keys hdr)++type AuthAttrs = M.Map ByteString ByteString+type AuthScheme = CI ByteString++hawkAuthParser :: [ByteString] -> (AuthAttrs -> Either String hdr) -> Parser (AuthScheme, hdr)+hawkAuthParser keys parseHdrs = do+  s <- scheme+  m <- authParser keys+  endOfInput+  case parseHdrs m of+    Right h -> return (s, h)+    Left a  -> fail a++authAttrMaybe :: AuthAttrs -> ByteString -> Maybe ByteString+authAttrMaybe m a = M.lookup a m++authAttr :: AuthAttrs -> ByteString -> Either String ByteString+authAttr m a = case authAttrMaybe m a of+  Just v  -> Right v+  Nothing -> Left $ S8.unpack ("Missing \"" <> a <> "\" attribute")++authParser :: [ByteString] -> Parser AuthAttrs+authParser keys = M.fromList <$> attrs (parseKeys keys)++scheme :: Parser AuthScheme+scheme = (CI.mk <$> stringCI "Hawk") <* skipSpace++attrs :: Parser ByteString -> Parser [(ByteString, ByteString)]+attrs key = (attr key <* skipSpace) `sepBy` (char8 ',' >> skipSpace)++attr :: Parser ByteString -> Parser (ByteString, ByteString)+attr key = (,) <$> key <*> (char8 '=' *> val)++parseKeys :: [ByteString] -> Parser ByteString+parseKeys = choice . map string++val :: Parser ByteString+val = q *> takeTill ((==) '"') <* q+      where q = char8 '"'++readTs :: ByteString -> Either String POSIXTime+readTs = toEither "Invalid timestamp" . readTsMaybe+  where+    toEither _ (Just a) = Right a+    toEither e Nothing  = Left e++-- | Hawk timestamps/bewit expirations are in seconds since the epoch,+-- unlike iron ttls and expiry.+readTsMaybe :: ByteString -> Maybe POSIXTime+readTsMaybe = fmap fromInteger . (>>= check) . S8.readInteger+  where+    -- there should be no left-overs from integer parse+    check (i, rest) = if S8.null rest then Just i else Nothing++parseHostnamePort :: ByteString -> (ByteString, Maybe Int)+parseHostnamePort hp = case parseOnly hostnamePort hp of+  Right r -> r+  Left _  -> ("", Nothing)++-- fixme: not sure whether to allow junk text after port++hostnamePort :: Parser (ByteString, Maybe Int)+hostnamePort = (,) <$> hostname <*> port++hostname :: Parser ByteString+hostname = takeTill ((==) ':')++port :: Parser (Maybe Int)+port = (Just <$> (char8 ':' *> decimal <* endOfInput)) <|> pure Nothing

@@ -0,0 +1,511 @@+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE NamedFieldPuns            #-}+{-# LANGUAGE RecordWildCards           #-}+{-# LANGUAGE ScopedTypeVariables       #-}++-- | <<images/iron-logo.png>>+--+-- /Iron/ is a cryptographic utility for sealing a JSON object using+-- symmetric key encryption with message integrity verification. Or in+-- other words, it lets you encrypt an object, send it around (in+-- cookies, authentication credentials, etc.), then receive it back+-- and decrypt it. The algorithm ensures that the message was not+-- tampered with, and also provides a simple mechanism for password+-- rotation.+--+-- For more information about the sealing/unsealing process, as well+-- as security considerations, see the+-- <https://github.com/hueniverse/iron Iron Website>.+--+-- == Usage+-- To seal an object:+--+-- >>> import Data.ByteString (ByteString)+-- >>> import Data.Aeson+-- >>> import qualified Network.Iron as Iron+-- >>> 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+-- >>> print s+-- "Fe26.2**3976da2bc627b3551c1ebfe40376bb791efb17f4425facc648038fdaaa2f67b2+-- *voiPExJrXAxmTWyQr7-Hvw*r_Ok7NOgy9sD2fS61t_u9z8qoszwBRze3NnA6PFmjnd06sLh0+-- 9HRDlLorNYQJeEP**f6e22615db961e5ddc2ed47d956700b2ee63f0ab6f7ae6d3471989e5+-- 4928e653*RsQNtNp4u5L-0fmZHSpPL7nbjBkqyKEyBcbOCbpEcpY"+--+-- The resulting "sealed" object is a string which can be sent via+-- cookies, URI query parameter, or a HTTP header attribute.+--+-- To unseal the string:+--+-- >>> Iron.unseal (onePassword secret) s :: IO (Either String Object)+-- Right (Object (fromList [("a",Number 1.0),+-- ("d",Object (fromList [("e",String "f")])),+-- ("b",Number 2.0),+-- ("c",Array [Number 3.0,Number 4.0,Number 5.0])]))++module Network.Iron+  ( seal+  , sealWith+  , unseal+  , unsealWith+  , password+  , passwords+  , passwordWithId+  , passwordsWithId+  , Password+  , PasswordId+  , LookupPassword+  , onePassword+  , Options(..)+  , EncryptionOpts(..)+  , IntegrityOpts(..)+  , IronCipher(..)+  , IronMAC(..)+  , SHA256(SHA256)+  , IronSalt(..)+  , urlSafeBase64+  ) where++import           Control.Monad          (liftM, when)+import           Crypto.Cipher.AES      (AES128, AES256 (..))+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.KDF.PBKDF2      as PBKDF2+import           Crypto.MAC.HMAC        (Context, HMAC, finalize, hmac,+                                         hmacGetDigest, initialize, updates)+import           Crypto.Random+import           Data.Aeson+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.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)+import           Data.Time.Clock        (NominalDiffTime)+import           Data.Time.Clock.POSIX+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+data Options = Options+  { ironEncryption      :: EncryptionOpts  -- ^ Encryption options+  , ironIntegrity       :: IntegrityOpts   -- ^ Message integrity verification options+  , ironTTL             :: NominalDiffTime -- ^ Message lifetime in seconds+  , ironTimestampSkew   :: NominalDiffTime -- ^ Clock difference allowance in seconds+  , ironLocaltimeOffset :: NominalDiffTime -- ^ Clock offset in seconds+  } deriving Show++-- | Encryption algorithms supported by Iron.+data IronCipher = AES128CTR | AES256CBC  deriving Show++class IsIronCipher a where+  ivSize :: a -> Int+  keySize :: a -> Int+  ironEncrypt :: a -> ByteString -> ByteString -> ByteString -> Maybe ByteString+  ironDecrypt :: a -> ByteString -> ByteString -> ByteString -> Maybe ByteString++class IsIronMAC a where+  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++-- | 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+  deriving Show++{-+todo:+ - maybe remove ieSalt/iiSalt and ieIV from opts? these values+   pre-generated by the user might only be necessary for unit tests.+-}++-- | Options controlling encryption of Iron messages.+data EncryptionOpts = EncryptionOpts+  { ieSalt       :: IronSalt -- ^ 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+  } deriving Show++-- | Options controlling cryptographic verification of Iron messages.+data IntegrityOpts = IntegrityOpts+  { iiSalt       :: IronSalt -- ^ Salt for MAC key generation+  , iiAlgorithm  :: IronMAC -- ^ 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+                       , ieIV = Nothing }++defaultsIntegrity :: IronMAC -> IntegrityOpts+defaultsIntegrity algo = IntegrityOpts+                         { iiSalt = IronGenSalt 256+                         , iiAlgorithm = algo+                         , iiIterations = 1 }++defaults :: Options+defaults = Options+  { ironEncryption = def+  , ironIntegrity = def+  , 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++-- | Represents the password(s) used to seal and unseal Iron+-- messages. To construct a 'Password', use one of 'password',+-- 'passwords', 'passwordWithId', 'passwordsWithId'.+data Password = MkPassword+  { passwordId :: PasswordId+  , encKey     :: KeyPass -- ^ Encryption key/password+  , intKey     :: KeyPass -- ^ Integrity key/password+  } deriving (Show, Eq)++-- | 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+             deriving (Show, Eq)+             -- note: SecureMem Show doesn't actually show any content++-- | Constructs a 'Password'.+password :: ToSecureMem 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 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 k p = passwordsWithId k p p++-- | Constructs a 'Password', with different encryption and integrity+-- verification passwords. 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.+passwordsWithId :: ToSecureMem a => PasswordId -> a -> a -> Maybe Password+passwordsWithId k e i | validId k = Just $ password' k e i+                      | otherwise = Nothing++validId :: PasswordId -> Bool+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++password' :: ToSecureMem a => PasswordId -> a -> a -> Password+password' k e i = MkPassword k (passwd e) (passwd i)+  where passwd = Password . toSecureMem++-- | User-supplied function to get the password corresponding to the+-- identifier from the sealed message.+type LookupPassword = PasswordId -> Maybe Password++-- | The simple case of LookupPassword, where there is the same+-- password for encryption and verification of all messages.+onePassword :: ToSecureMem 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+  s <- getSealStuff opts+  return $ seal' opts s p v++-- | Variables necessary for sealing whose values come from the+-- IO world.+data SealStuff = SealStuff+  { ssNow     :: POSIXTime+  , ssEncSalt :: ByteString+  , ssIv      :: ByteString+  , ssIntSalt :: ByteString+  } deriving (Show)++-- | Gets the time, generate random numbers.+getSealStuff :: Options -> IO SealStuff+getSealStuff opts@Options{..} = do+  now <- getPOSIXTime+  drg1 <- getSystemDRG+  let (encSalt, drg2) = genSaltMaybe (ieSalt ironEncryption) drg1+  let (intSalt, drg3) = genSaltMaybe (iiSalt ironIntegrity) drg2+  let (iv, _) = genIVMaybe (ieAlgorithm ironEncryption) (ieIV ironEncryption) drg3+  return $ SealStuff (now + ironLocaltimeOffset) encSalt iv intSalt+++-- | Effects-pure part of sealing process.+--+-- The seal process follows these general steps:+--   generate encryption salt saltE+--   derive an encryption key keyE using saltE and a password+--   generate an integrity salt saltI+--   derive an integrity (HMAC) key keyI using saltI+--   generate a random initialization vector iv+--   encrypt the serialized object string using keyE and iv+--   mac the encrypted object along with saltE and iv+--   concatenate saltE, saltI, iv, and the encrypted object into a URI-friendly string+seal' :: forall a. ToJSON a => Options -> SealStuff -> Password -> a -> Maybe ByteString+seal' opts SealStuff{..} sec a = encrypt a >>= fmap strCookie . mac . strEncCookie+  where+    encrypt :: a -> Maybe EncCookie+    encrypt obj = do+      key <- rightJust $ generateKey ieIterations size ssEncSalt (encKey sec)+      ctext <- ironEncrypt ieAlgorithm key ssIv json+      return $ EncCookie (passwordId sec) ssEncSalt ssIv expiration ctext+      where+        EncryptionOpts{..} = ironEncryption opts+        json = BL.toStrict $ JSON.encode obj+        expiration = expTime opts ssNow+        size = keySize ieAlgorithm++    mac :: ByteString -> Maybe Cookie+    mac str = Cookie str ssIntSalt <$> rightJust digest+      where+        digest = hmacWithPassword intOpts key ssIntSalt str+        intOpts = ironIntegrity opts+        key = intKey sec++data EncCookie = EncCookie+  { ckPasswordId :: PasswordId+  , ckEncSalt    :: ByteString+  , ckIv         :: ByteString+  , ckExpiration :: Maybe NominalDiffTime+  , ckText       :: ByteString+  } deriving Show++data Cookie = Cookie+  { ckEnc       :: ByteString+  , ckIntSalt   :: ByteString+  , ckIntDigest :: ByteString+  } deriving Show++strEncCookie :: EncCookie -> ByteString+strEncCookie (EncCookie pid s iv e t) = cat [macPrefix, pid, s, b64url iv, b64url t, expStr e]++strCookie :: Cookie -> ByteString+strCookie (Cookie a b c) = cat [a, b, c]++parseCookie :: ByteString -> Either String (EncCookie, Cookie)+parseCookie ck = do+  when (length parts /= 8) $ Left "Incorrect number of sealed components"+  when (pfx /= macPrefix) $ Left "Wrong mac prefix"+  eck <- EncCookie <$> pure a <*> pure b <*> b64' c <*> exp e <*> b64' d+  return (eck, Cookie enc f g)+  where+    parts = uncat ck+    (pfx:a:b:c:d:e:f:g:[]) = parts+    enc = cat $ take 6 parts+    exp :: ByteString -> Either String (Maybe NominalDiffTime)+    exp "" = Right Nothing+    exp n = maybe (Left "Invalid expiration") (Right . Just) $ parseExpMsec n+    b64' = b64urldec++cat :: [ByteString] -> ByteString+cat = BS.intercalate (S8.singleton '*')++uncat :: ByteString -> [ByteString]+uncat = S8.split '*'++expStr :: Maybe NominalDiffTime -> ByteString+expStr = maybe "" (S8.pack . show . round)++expTime :: Options -> POSIXTime -> Maybe NominalDiffTime+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)++generateKey :: Int -> Int -> ByteString -> KeyPass -> Either String ByteString+generateKey _ s _ (Key k) | byteableLength k >= s = Right (toBytes 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+  where+    prf = PBKDF2.prfHMAC SHA1+    params = PBKDF2.Parameters iterations size++-- | Calculates integrity hash.+hmacWithPassword :: IntegrityOpts -> KeyPass -> ByteString -> ByteString+                 -> Either String ByteString+hmacWithPassword IntegrityOpts{..} key salt text = do+  key' <- generateKey iiIterations (macKeySize iiAlgorithm) salt key+  Right $ macWithKey iiAlgorithm key' text++-- | Prepares the variables necessary to use cryptonite block cipher+-- functions.+aesSetup :: BlockCipher c => ByteString -> ByteString -> Maybe (c, IV c, Format)+aesSetup key iv = (,,) <$> ctx <*> iv' <*> p+  where+    ctx = maybeCryptoError (cipherInit key)+    iv' = makeIV iv+    p = fmap (PKCS7 . blockSize) ctx++instance IsIronCipher IronCipher where+  -- IV is the size of one block+  ivSize AES128CTR = blockSize (undefined :: AES128)+  ivSize AES256CBC = blockSize (undefined :: AES256)++  -- Iron's chosen key size -- should fall within the range of+  -- cryptonite cipherKeySize+  keySize AES128CTR = 16+  keySize AES256CBC = 32++  -- Encrypt with AES block counter mode+  ironEncrypt AES128CTR key iv text = do+    (ctx :: AES128, iv', p) <- aesSetup key iv+    return $ ctrCombine ctx iv' (pad p text)++  -- Encrypt with AES block chaining mode+  ironEncrypt AES256CBC key iv text = do+    (ctx :: AES256, iv', p) <- aesSetup key iv+    let text' = pad p text+    return $ cbcEncrypt ctx iv' text'++  -- Decrypt with AES block counter mode+  ironDecrypt AES128CTR key iv ctext = do+    (ctx :: AES128, iv', p) <- aesSetup key iv+    unpad p (ctrCombine ctx iv' ctext)++  -- Decrypt with AES block chaining mode+  ironDecrypt AES256CBC key iv ctext = do+    (ctx :: AES256, iv', p) <- aesSetup key iv+    let text' = cbcDecrypt ctx iv' ctext+    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+  now <- getPOSIXTime+  return $ unseal' opts now p t++-- | Effects-pure part of unsealing process.+unseal' :: FromJSON a => Options -> POSIXTime -> LookupPassword -> ByteString -> Either String a+unseal' opts now p cookie = do+  (eck, ck) <- parseCookie cookie+  _ <- checkExpiration now (ironTimestampSkew opts) eck+  MkPassword _ enc int <- getPassword opts (ckPasswordId eck) p+  ok <- verify ck int+  decrypt eck enc >>= JSON.eitherDecode' . BL.fromStrict+  where+    decrypt :: EncCookie -> KeyPass -> Either String ByteString+    decrypt EncCookie{..} sec = do+      let EncryptionOpts{..} = ironEncryption opts+          size = keySize ieAlgorithm+      key <- generateKey ieIterations size ckEncSalt sec+      case ironDecrypt ieAlgorithm key ckIv ckText of+        Just ctext -> Right ctext+        Nothing -> Left "Iron decryption failed"++    verify :: Cookie -> KeyPass -> Either String ()+    verify Cookie{..} sec = do+      digest <- hmacWithPassword (ironIntegrity opts) sec ckIntSalt ckEnc+      if constEqBytes ckIntDigest digest+        then Right ()+        else Left "Bad hmac value"++    checkExpiration :: NominalDiffTime -> NominalDiffTime -> EncCookie -> Either String ()+    checkExpiration now skew EncCookie{ckExpiration} = if isExpired now skew ckExpiration+                                                          then Left "Expired seal"+                                                          else Right ()++    getPassword :: Options -> PasswordId -> LookupPassword -> Either String Password+    getPassword opts pid lookup = case lookup pid of+                                    Just p -> Right p+                                    Nothing -> Left $ "Cannot find password: " <> S8.unpack pid++isExpired :: POSIXTime -> NominalDiffTime -> Maybe POSIXTime -> Bool+isExpired _ _ Nothing         = False+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++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++genIVMaybe :: DRG gen => IronCipher -> Maybe ByteString -> gen -> (ByteString, gen)+genIVMaybe _ (Just iv)  = \gen -> (iv, gen)+genIVMaybe algo Nothing = genIV (ivSize algo)++macPrefix, macFormatVersion :: ByteString+macPrefix = "Fe26." <> macFormatVersion+macFormatVersion = "2"

@@ -0,0 +1,82 @@+-- | Miscellaneous shortcut functions, mostly for internal use.++module Network.Iron.Util (+  -- * Base64+    b64+  , b64dec+  , b64url+  , b64urldec+  , urlSafeBase64+  , unUrlSafeBase64+  -- * 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 encode in Base64.+b64 :: ByteArrayAccess a => a -> ByteString+b64 = B.convertToBase B.Base64++b64url :: ByteArrayAccess a => a -> ByteString+b64url = urlSafeBase64 . b64++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) '='++-- | Reads a positive integer time value in milliseconds. This is for+-- parsing ttls or expiry times written as milliseconds since the unix+-- epoch.+parseExpMsec :: ByteString -> Maybe NominalDiffTime+parseExpMsec = (>>= fromMsec . guard) . readMaybe . S8.unpack+  where+    fromMsec = fmap ((/ 1000) . fromInteger)+    -- ttls must be positive+    guard n | n > 0 = Just n+            | otherwise = Nothing+++-- | Converts 'Either' to 'Maybe'.+rightJust :: Either e a -> Maybe a+rightJust (Right a) = Just a+rightJust _ = Nothing++-- | Converts 'Maybe' to 'Either'.+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 :: (e -> e') -> Either e a -> Either e' a+mapLeft f (Left e) = Left (f e)+mapLeft _ (Right a) = Right a

@@ -0,0 +1,45 @@+-- | <<images/oz.png>>+--+-- Oz is a web authorization protocol based on industry best+-- practices. Oz combines the "Network.Hawk" authentication protocol+-- with the "Network.Iron" encryption protocol to provide a simple to+-- use and secure solution for granting and authenticating third-party+-- access to an API on behalf of a user or an application.+--+-- For making Oz-authenticated requests, import the+-- "Network.Oz.Client" module, which provides wrappers around+-- "Network.Wreq".+--+-- When implementing an Oz-authenticated application, import+-- "Network.Oz.Application" and use 'Network.Oz.Application.ozApp' to+-- provide a WAI 'Network.Wai.Application' and plug it into your+-- application. The endpoints will handle issuing tickets.+--+-- 'Network.Oz.Server.authenticate' checks tickets provided with+-- 'Network.Wai.Request's.+--+-- == How it works+--+-- 1. The application uses its previously issued Hawk credentials to+--    authenticate with the server and request an application+--    ticket. If valid, the server issues an application ticket. (see+--    'Network.Oz.Application.app' endpoint)+-- 2. The application directs the user to grant it authorization by+--    providing the user with its application identifier. The user+--    authenticates with the server, reviews the authorization grant+--    and its scope, and if approved the server returns an rsvp. (see+--    'Network.Oz.Ticket.rsvp' function)+-- 3. The user returns to the application with the rsvp which the+--    application uses to request a new user-specific ticket. If+--    valid, the server returns a new ticket. (see+--    'Network.Oz.Application.rsvp' endpoint)+-- 4. The application uses the user-ticket to access the user's+--    protected resources. (see 'Network.Oz.Server.authenticate'+--    function)+--++module Network.Oz+  ( module Network.Oz.Types+  ) where++import           Network.Oz.Types

@@ -0,0 +1,223 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE NamedFieldPuns #-}++-- | Provides a "Network.Wai" 'Network.Wai.Application' for managing+-- Oz tickets.+--+-- The Oz ticket endpoints can be run with Warp or embedded within+-- another application.++module Network.Oz.Application+  ( ozApp+  , ozAuth+  , OzServerOpts(..)+  , OzLoadApp+  , OzLoadGrant+  , defaultOzServerOpts+  , ozAppScotty+  ) where++import           Control.Monad             (liftM, void, when)+import           Control.Monad.IO.Class    (MonadIO (..), liftIO)+import           Control.Monad.Trans.Either+import           Control.Applicative       ((<|>))+import           Data.Aeson.Types          (ToJSON)+import           Data.ByteString           (ByteString)+import           Data.Maybe                (fromMaybe, isJust)+import           Data.Monoid               ((<>))+import           Data.Proxy+import           Data.Text                 (Text)+import qualified Data.Text                 as T+import           Data.Text.Encoding        (decodeUtf8, encodeUtf8)+import qualified Data.Text.Lazy            as TL+import           Network.HTTP.Types        (status400, status401)+import           Network.Wai+import           Web.Scotty+import           Data.Time.Clock.POSIX     (getPOSIXTime)++import           Network.Hawk.Server       (AuthSuccess (..), Key (..), HeaderArtifacts (..))+import qualified Network.Hawk.Server       as Hawk+import qualified Network.Oz.Boom           as Boom+import           Network.Oz.Internal.Types+import           Network.Oz.JSON+import           Network.Oz.Server+import qualified Network.Oz.Ticket         as Ticket+import           Network.Oz.Types++data OzServerOpts = OzServerOpts+  { ozSecret     :: Key -- ^ The password for encrypting Oz tickets+  , ozLoadApp    :: OzLoadApp -- ^ Callback to look up registered apps+  , ozLoadGrant  :: OzLoadGrant -- ^ Callback to look up grants+  , ozTicketOpts :: TicketOpts -- ^ Ticket generation options+  , ozHawk       :: Hawk.AuthReqOpts -- ^ Configuration of Hawk for this server+  , ozEndpoints  :: Endpoints -- ^ URL route configuration of API endpoints+  }++-- | An empty Oz endpoint configuration. The password should be set to+-- something secret.+defaultOzServerOpts :: Key -> OzServerOpts+defaultOzServerOpts p = OzServerOpts p defaultLoadApp defaultLoadGrant+  defaultTicketOpts Hawk.defaultAuthReqOpts defaultEndpoints++defaultLoadApp :: OzLoadApp+defaultLoadApp _ = return $ Left "ozLoadApp not set"++defaultLoadGrant :: OzLoadGrant+defaultLoadGrant _ = return $ Left "ozLoadGrant not set"++-- | Starts the 'Network.Wai.Application'.+ozApp :: OzServerOpts -> IO Application+ozApp = scottyApp . ozAppScotty++-- | The Oz endpoints are actually implemented using+-- "Web.Scotty". This provides the 'Web.Scotty.ScottyM' application+-- which can be embedded within other Scotty apps.+ozAppScotty :: OzServerOpts -> ScottyM ()+ozAppScotty OzServerOpts{..} = do+  defaultHandler Boom.errHandler+  let post' r = post . literal . T.unpack . r $ ozEndpoints+  post' endpointApp     $ app >>= ejson+  post' endpointReissue $ jsonData >>= reissue >>= json+  post' endpointRsvp    $ jsonData >>= rsvp >>= json+  where+    app :: ActionM (Either String OzSealedTicket)+    app = do+      (creds, arts) <- hawkAuthAction+      appCfg <- loadAppAction (shaApp arts)+      Ticket.issue ozSecret appCfg Nothing ozTicketOpts++    -- fixme: flatten staircases ... use EitherT+    reissue :: ReissueRequest -> ActionM OzSealedTicket+    reissue (ReissueRequest mid mscope) = do+      res <- request >>= authenticateExpired ozSecret ozTicketOpts ozHawk+      case res of+        Right (AuthSuccess c a t) -> do+          let appId = ozTicketApp (ozTicket t)+          appCfg <- liftIO $ ozLoadApp appId+          case appCfg of+            Right app -> do+              when (isJust mid && not (ozAppDelegate app)) $+                Boom.forbidden "Application has no delegation rights"+              case ozTicketGrant (ozTicket t) of+                Nothing -> reissueAction c app Nothing Nothing mid mscope t+                Just gid -> do+                  mgrant <- liftIO $ ozLoadGrant gid+                  case mgrant of+                    Right (grant, mext) -> do+                      now <- liftIO $ getPOSIXTime+                      when (((ozGrantApp grant /= ozTicketApp (ozTicket t)) &&+                             (Just (ozGrantApp grant) /= ozTicketDlg (ozTicket t))) ||+                             (ozGrantExp grant <= now)) $ Boom.unauthorized "Invalid grant"+                      reissueAction c app (Just grant) mext mid mscope t+                    Left e -> Boom.forbidden e+            Left e -> Boom.unauthorized (e <|> "Invalid application")+        Left e -> hawkAuthFail e++    reissueAction :: Hawk.Credentials -> OzApp -> Maybe OzGrant -> Maybe OzExt+                   -> Maybe OzAppId -> Maybe OzScope -> OzSealedTicket -> ActionM OzSealedTicket+    reissueAction creds a mgrant mext mid mscope t = do+      res <- Ticket.reissue ozSecret a mgrant (opts mext) mscope mid t+      either Boom.forbidden return res+      where+        opts (Just ext) = ozTicketOpts { ticketOptsExt = ext }+        opts Nothing = ozTicketOpts++    -- Authenticates an application request and if valid, exchanges+    -- the provided rsvp with a ticket.+    rsvp :: RsvpRequest -> ActionM OzSealedTicket+    rsvp (RsvpRequest r) = do+      res <- request >>= authenticate ozSecret ozTicketOpts ozHawk+      case res of+        Right (AuthSuccess c a t) -> do+          when (ozTicketUser (ozTicket t) == Nothing) $+            Boom.unauthorized "User ticket cannot be used on an application endpoint"+          mt <- liftIO $ Ticket.parse ozTicketOpts ozSecret (encodeUtf8 r)+          case mt of+            Right envelope -> do+              when (ozTicketApp (ozTicket envelope) /= (ozTicketApp (ozTicket t))) $+                Boom.forbidden "Mismatiching ticket and rsvp apps"+              now <- liftIO $ getPOSIXTime+              when (ozTicketExp (ozTicket envelope) <= now) $+                Boom.forbidden "Expired rsvp"+              case ozTicketGrant (ozTicket envelope) of+                Just gid -> do+                  mgrant <- liftIO $ ozLoadGrant gid+                  case mgrant of+                    Right (grant, mext) -> do+                      when ((ozGrantApp grant /= ozTicketApp (ozTicket envelope)) ||+                            (ozGrantExp grant <= now)) $ Boom.forbidden "Invalid grant"+                      appCfg <- liftIO $ ozLoadApp (ozTicketApp (ozTicket envelope))+                      case appCfg of+                        Right app -> do+                          let opts' = case mext of+                                        Just ext -> ozTicketOpts { ticketOptsExt = ext }+                                        Nothing -> ozTicketOpts+                          res <- Ticket.issue ozSecret app (Just grant) opts'+                          either Boom.forbidden return res+                        Left e -> Boom.forbidden (e <|> "Invalid application")+                    Left e -> Boom.forbidden e -- probably forbidden+                Nothing -> Boom.forbidden "Missing grant id"+            Left e -> Boom.forbidden e+        Left f -> hawkAuthFail f++    -- Scotty action to check the Authorization header+    hawkAuthAction :: ActionM (Hawk.Credentials, Hawk.HeaderArtifacts)+    hawkAuthAction = do+      req <- request+      -- payload <- fmap Just body  -- fixme: check if it's compatible with jsonData+      let payload = Nothing+      let creds = liftIO . liftM (fmap appCreds) . ozLoadApp+      res <- Hawk.authenticateRequest ozHawk creds req payload+      case res of+        Right (AuthSuccess c a _) -> return (c, a)+        Left f                  -> hawkAuthFail f++    -- respond to failed hawk authentication+    hawkAuthFail :: Hawk.AuthFail -> ActionM a+    hawkAuthFail (Hawk.AuthFailBadRequest e _)       = Boom.badRequest e+    hawkAuthFail (Hawk.AuthFailUnauthorized e _ _)   = Boom.unauthorized e+    -- fixme: need to send back server's time so client can apply offset+    hawkAuthFail (Hawk.AuthFailStaleTimeStamp e c a) = Boom.unauthorized e++    loadAppAction appId = do+      appCfg <- liftIO $ loadApp appId+      case appCfg of+        Right app -> return app+        Left e    -> Boom.unauthorized e++    loadApp Nothing      = return $ Left "Invalid application object"+    loadApp (Just appId) = ozLoadApp appId++    ejson :: ToJSON a => Either String a -> ActionM ()+    ejson = either Boom.internal json++appCreds :: OzApp -> (Hawk.Credentials, ())+appCreds OzApp{..} = (Hawk.Credentials ozAppKey ozAppAlgorithm, ())++-- | "Network.Wai" 'Network.Wai.Middleware' for Oz+-- authentication. Resources can be selectively protected by applying+-- 'Network.Wai.ifRequest' to the middleware.+ozAuth :: OzServerOpts -> Middleware+ozAuth opts app req sendResponse = do+  res <- ozAuthenticate opts req+  case res of+    -- fixme: store ticket in vault+    Right _ -> app req sendResponse+    Left e -> ozAuthFail req sendResponse e+  where+    ozAuthFail req sendResponse e = sendResponse $ responseLBS+      status401+      [ ("Content-Type", "text/plain") -- hContentType+      , ("WWW-Authenticate", "Oz") -- fixme: make it correct+      ]+      "Oz authentication is required"++ozAuthenticate :: MonadIO m => OzServerOpts -> Request -> m (Hawk.AuthResult OzSealedTicket)+ozAuthenticate OzServerOpts{..} = authenticate ozSecret ozTicketOpts ozHawk++-- | Helper function to get the full URL of an Oz endpoint based on+-- the Host header in a request.+ozAppUrl :: OzServerOpts -> (Endpoints -> Text) -> Request -> Maybe Text+ozAppUrl OzServerOpts{ozEndpoints} ep = fmap make . requestHeaderHost+  where+    make host = decodeUtf8 host <> ep ozEndpoints

@@ -0,0 +1,77 @@+-- | Emulation of HapiJS Boom responses.++module Network.Oz.Boom+  ( badRequest+  , unauthorized+  , forbidden+  , internal+  , errHandler+  ) where++import           Control.Monad.IO.Class    (MonadIO (..), liftIO)+import           Data.Aeson                (Value (..), object, (.=))+import           Data.Maybe                (fromMaybe)+import           Data.Monoid               ((<>))+import           Data.Text.Encoding        (decodeUtf8)+import           Data.Text.Lazy            (Text, pack, toStrict)+import qualified Data.Text.Lazy            as TL+import           Network.HTTP.Types.Status (Status (..), mkStatus, status400,+                                            status401, status403, status500)+import           Text.Read                 (readMaybe)+import           Web.Scotty.Trans++-- fixme: can't figure out scotty custom error types, so am doing lame+-- conversion of status codes to strings.+{-+import Control.Monad.Error++instance Error Boom where+  strMsg = Boom status500++data Boom = Boom Status String+  deriving (Show, Eq)++instance ScottyError Boom where+  stringError = Boom status500+  showError = TL.pack . show+-}++type Boom = Text++badRequest :: Monad m => String -> ActionT Boom m a+badRequest e = boom status400 e++unauthorized :: Monad m => String -> ActionT Boom m a+unauthorized e = boom status401 e++forbidden :: Monad m => String -> ActionT Boom m a+forbidden e = boom status403 e++internal :: Monad m => String -> ActionT Boom m a+internal e = boom status500 e++boom :: Monad m => Status -> String -> ActionT Boom m a+boom code e = do+  status code+  let e' = pack e+  json $ boomObject code e'+  raise $ pack (show (statusCode code)) <> " " <> e'+  -- raise (Boom code e)++boomObject :: Status -> Text -> Value+boomObject code msg = object+  [ "statusCode" .= statusCode code+  , "error" .= decodeUtf8 (statusMessage code)+  , "message" .= msg+  ]++{-+errHandlerBoom :: Monad m => Boom -> ActionT Boom m ()+errHandlerBoom (Boom code msg) = status code+-}++errHandler :: MonadIO m => Text -> ActionT Text m ()+errHandler e = do+  liftIO $ putStrLn $ "*** errHandler " ++ show e+  let (code, msg) = TL.break (== ' ') e+  status $ maybe status500 toEnum (readMaybe (TL.unpack code))

@@ -0,0 +1,119 @@+{-# LANGUAGE RecordWildCards #-}++-- | Functions for making Oz-authenticated requests.+--+-- This module is under construction.++module Network.Oz.Client+  ( header+  -- , withSession+  , reissue+  , Endpoints(..)+  , defaultEndpoints+  ) where++import           Data.ByteString           (ByteString)+import           Data.Text                 (Text)+import           Data.Time.Clock.POSIX     (POSIXTime, getPOSIXTime)++-- import Network.HTTP.Types.URI (URI)+import           Network.HTTP.Client       (Request, defaultManagerSettings,+                                            managerModifyRequest,+                                            managerRetryableException)+import           Network.HTTP.Types.Header (Header, hWWWAuthenticate)+import           Network.HTTP.Types.Method (Method)++import           Control.Exception         (SomeException)+import           Data.IORef                (newIORef, readIORef, writeIORef)++-- import Network.Wai (Request, requestHeaderHost, requestHeaders, remoteHost, requestMethod, rawPathInfo, rawQueryString)++{-+import           Network.Wreq.Session      (Session)+import qualified Network.Wreq.Session      as S+-}++import qualified Network.Hawk.Client       as Hawk+import           Network.Oz.Types++-- |A convenience utility to generate the application Hawk request+-- authorization header for making authenticated Oz requests.+header :: Text -> Method -> OzSealedTicket -> IO Hawk.Header+-- fixme: support hawk header options+header uri method t@OzSealedTicket{..} = Hawk.header uri method creds Nothing Nothing+  where+    creds = ticketCreds t+    -- fixme: app and dlg need to get passed to header++ticketCreds :: OzSealedTicket -> Hawk.Credentials+ticketCreds OzSealedTicket{..} = Hawk.Credentials ozTicketId ozTicketKey ozTicketAlgorithm++{-+-- | Work in progress.+withSession :: Endpoints -> Text -> Hawk.Credentials -> (Session -> IO a) -> IO a+withSession ep uri creds act = do+  ref <- newIORef (Nothing :: Maybe OzTicket)+  S.withSessionControl Nothing settings act+  where+    settings = defaultManagerSettings+               { managerModifyRequest = addAuth+               , managerRetryableException = shouldRetry }+    addAuth :: Request -> IO Request+    -- fixme: check ticket ref+    addAuth = return+    shouldRetry :: SomeException -> Bool+    -- fixme: catch unauthorized and retry with auth+    shouldRetry = managerRetryableException defaultManagerSettings+-}++-- | Re-issues (refreshes) a ticket.+reissue :: Endpoints -> Hawk.Credentials -> OzTicket -> IO (Either String OzTicket)+reissue ep creds OzTicket{..} = undefined -- fixme: implement++-- | Re-issues a ticket if it has expired.+-- fixme: maybe need slightly earlier reissue+reissueMaybe :: Endpoints -> Hawk.Credentials -> OzTicket -> IO (Either String OzTicket)+reissueMaybe ep creds t = do+  now <- getPOSIXTime+  if now >= ozTicketExp t+    then reissue ep creds t+    else return (Right t)++{- connection.request(path, ticket, options, callback)++Requests a protected resource where:++path - the resource path (e.g. '/resource').+ticket - the application or user ticket. If the ticket is expired, it will automatically attempt to refresh it.+options - optional configuration object where:+method - the HTTP method (e.g. 'GET'). Defaults to 'GET'.+payload - the request payload object or string. Defaults to no payload.+callback - the callback method using the signature function(err, result, code, ticket) where:+err - an error condition.+result - the requested resource (parsed to object if JSON).+code - the HTTP response code.+ticket - the ticket used to make the request (may be different from the ticket provided when the ticket was expired and refreshed).++-> sessionRequest+  probably not needed because withSession should handle ticket+++connection.app(path, options, callback)++Requests a protected resource using a shared application ticket where:++path - the resource path (e.g. '/resource').+options - optional configuration object where:+method - the HTTP method (e.g. 'GET'). Defaults to 'GET'.+payload - the request payload object or string. Defaults to no payload.+callback - the callback method using the signature function(err, result, code, ticket) where:+err - an error condition.+result - the requested resource (parsed to object if JSON).+code - the HTTP response code.+ticket - the ticket used to make the request (may be different from the ticket provided when the ticket was expired and refreshed).+Once an application ticket is obtained internally using the provided hawk credentials in the constructor, it will be reused by called to connection.app(). If it expires, it will automatically refresh and stored for future usage.++-> sessionRequestApp+   not sure if needed++-}

@@ -0,0 +1,24 @@+module Network.Oz.Internal.Types+  ( ReissueRequest(..)+  , RsvpRequest(..)+  ) where++import           Data.Text        (Text)++-- fixme: needs to be the other way around+import           Network.Oz.Types (OzAppId, OzScope)++-- | Payload for oz app reissue endpoint.+-- 'OzAppId' A different application identifier than the one+-- of the current application. Used to delegate+-- access between applications. Defaults to the+-- current application.+-- 'OzScope' An array of scope strings which must be a+-- subset of the ticket's granted scope. Defaults to+-- the original ticket scope.+data ReissueRequest = ReissueRequest (Maybe OzAppId) (Maybe OzScope)++-- | Payload for oz app rsvp endpoint.+-- Single field is the required rsvp string provided to the user to+-- bring back to the application after granting authorization+data RsvpRequest = RsvpRequest Text

@@ -0,0 +1,99 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TupleSections   #-}+module Network.Oz.JSON where++import           Data.Aeson+import           Data.Aeson.Types+import qualified Data.Aeson.Types          as JSON+import           Data.Char                 (toLower)+import           Data.Maybe                (catMaybes)+import           Data.Scientific           (toRealFloat)+import           Data.Text                 (Text)+import qualified Data.Text                 as T (null, pack, unpack)+import           Data.Text.Encoding        (decodeUtf8, encodeUtf8)+import           Data.Time.Clock.POSIX     (POSIXTime)++import           Network.Hawk.Types+import           Network.Oz.Internal.Types+import           Network.Oz.Types++fieldModifier :: String -> String+fieldModifier = drop 1 . dropWhile (/= '_') . dropWhile (== '_') . camelTo '_'++opts = defaultOptions { JSON.fieldLabelModifier = fieldModifier }++instance ToJSON OzSealedTicket where+  toJSON OzSealedTicket{..} = object $ ticketObj ozTicket ++ mid +++                              [ "key" .= fromKey ozTicketKey+                              , "algorithm" .= ozTicketAlgorithm+                              ] ++ ext+    where+      fromKey (Key k) = decodeUtf8 k+      mid = if T.null ozTicketId then [] else [("id", String ozTicketId)]+      ext = if ozTicketExt == mempty then [] else ["ext" .= ozTicketExt]++instance ToJSON OzTicket where+  toJSON ticket = object $ ticketObj ticket++ticketObj :: OzTicket -> [Pair]+ticketObj OzTicket{..} = catMaybes+                         [ Just ("exp", toMsec ozTicketExp)+                         , Just ("app", String ozTicketApp)+                         , Just ("scope", toJSON ozTicketScope)+                         , may "grant" ozTicketGrant+                         , may "user" ozTicketUser+                         , may "dlg" ozTicketDlg+                         , Just ("delegate", Bool ozTicketDelegate)+                         ]+  where+    toMsec = Number . fromIntegral . round . (* 1000)+    may k = fmap ((k,) . String)++instance FromJSON OzSealedTicket where+  parseJSON (Object v) = OzSealedTicket+                         <$> parseJSON (Object v)+                         <*> v .: "key"+                         <*> v .: "algorithim"+                         <*> v .: "ext"+                         <*> pure ""+  parseJSON invalid = typeMismatch "Ticket" invalid++instance FromJSON OzTicket where+  parseJSON (Object v) = OzTicket+                         <$> fmap fromMsec (v .: "exp")+                         <*> v .: "app"+                         <*> v .:? "user"+                         <*> v .:? "scope" .!= []+                         <*> v .:? "grant"+                         <*> v .: "delegate" .!= True+                         <*> v .:? "dlg"+    where+      fromMsec = realToFrac . toRealFloat . (/ 1000)++  parseJSON invalid = typeMismatch "Ticket" invalid++instance ToJSON HawkAlgo where+  toJSON = String . T.pack . show++instance FromJSON HawkAlgo where+  parseJSON (String s) = case readHawkAlgo (T.unpack s) of+                           Just a  -> return a+                           Nothing -> fail "Unknown algorithm"++instance ToJSON OzExt where+  toJSON = genericToJSON opts++instance FromJSON OzExt where+  parseJSON = genericParseJSON opts++instance FromJSON Key where+  parseJSON (String v) = return $ Key (encodeUtf8 v)+  parseJSON invalid    = typeMismatch "Key" invalid++instance FromJSON ReissueRequest where+  parseJSON (Object v) = ReissueRequest <$>+                           v .:? "issueTo" <*>+                           v .:? "scope"++instance FromJSON RsvpRequest where+  parseJSON (Object v) = RsvpRequest <$> v .: "rsvp"

@@ -0,0 +1,79 @@+{-# LANGUAGE RecordWildCards     #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | Functions for implementing an Oz server.++module Network.Oz.Server+  ( authenticate+  , authenticateExpired+  , authenticate'+  , CheckExpiration(..)+  ) where++import           Control.Monad          (when)+import           Control.Monad.IO.Class (MonadIO (..))+import           Data.ByteString        (ByteString)+import           Data.Maybe             (fromMaybe)+import           Data.Text              (Text)+import           Data.Text.Encoding     (encodeUtf8, decodeUtf8)+import           Data.Time.Clock.POSIX  (getPOSIXTime)+import           Network.Wai++import           Network.Hawk.Server    (AuthFail (..), AuthResult, AuthResult' (..),+                                         AuthSuccess (..),+                                         Credentials(..),+                                         HeaderArtifacts(..))+import qualified Network.Hawk.Server    as Hawk+import           Network.Hawk.Types+import qualified Network.Oz.Ticket      as Ticket+import           Network.Oz.Types++data CheckExpiration = CheckExpiration | AllowExpired deriving Show++-- | Authenticates a 'Network.Wai.Request' using Hawk+-- 'Network.Hawk.Server.authenticateRequest'. The Oz ticket is+-- decrypted and decoded from the Hawk attributes.+authenticate :: forall m. MonadIO m => Key -> TicketOpts -> Hawk.AuthReqOpts -> Request+             -> m (AuthResult OzSealedTicket)+authenticate = authenticate' CheckExpiration++-- | Same as 'authenticate' but expired Oz tickets are permitted.+authenticateExpired :: forall m. MonadIO m => Key -> TicketOpts -> Hawk.AuthReqOpts -> Request+                    -> m (AuthResult OzSealedTicket)+authenticateExpired = authenticate' AllowExpired++-- | 'authenticate' and 'authenticateExpired' are written in terms of+-- this function.+authenticate' :: forall m. MonadIO m => CheckExpiration -> Key -> TicketOpts -> Hawk.AuthReqOpts -> Request+                 -> m (AuthResult OzSealedTicket)+authenticate' ce p opts hawkOpts req =+  check <$> Hawk.authenticateRequest hawkOpts creds req Nothing+  where+    check :: AuthResult OzSealedTicket -> AuthResult OzSealedTicket+    check r = r >>= check'+      where+        check' r@(AuthSuccess c a@HeaderArtifacts{..} t@OzSealedTicket{..})+          | ozTicketApp ozTicket /= fromMaybe "" shaApp =+            Left $ AuthFailUnauthorized "Mismatching application id" (Just c) (Just a)+          | ozTicketDlg ozTicket /= fmap decodeUtf8 shaDlg && ozTicketDlg ozTicket /= Nothing =+            Left $ AuthFailUnauthorized "Mismatching delegated application id" (Just c) (Just a)+          | otherwise = Right r++    creds :: OzAppId -> m (Either String (Hawk.Credentials, OzSealedTicket))+    creds cid = liftIO $ fmap ticketCreds <$> ticket (encodeUtf8 cid)++    ticket :: ByteString -> IO (Either String OzSealedTicket)+    -- fixme: maybe use case instead of either+    ticket t = Ticket.parse opts p t >>= either (return . Left) checkExpiry++    checkExpiry sealed = case ce of+      CheckExpiration -> do+        now <- getPOSIXTime+        return $ if ozTicketExp (ozTicket sealed) <= now+          then Left "Expired ticket"+          else Right sealed+      AllowExpired -> return $ Right sealed++ticketCreds :: OzSealedTicket -> (Hawk.Credentials, OzSealedTicket)+ticketCreds t@OzSealedTicket{..} = (c, t)+  where c = Hawk.Credentials ozTicketKey ozTicketAlgorithm

@@ -0,0 +1,185 @@+{-# LANGUAGE RecordWildCards     #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections       #-}++-- | This module is best imported qualified.+-- Unless you are writing your own Oz endpoints, all you+-- will need for a normal application server is 'rsvp'.++module Network.Oz.Ticket+  ( rsvp+  , issue+  , reissue+  , parse+  ) where++import           Control.Monad          (liftM, void, when)+import           Control.Monad.IO.Class (MonadIO (..), liftIO)+import           Control.Applicative    ((<|>))+import           Data.Monoid            ((<>))+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           Data.List              (isInfixOf, nub)+import           Data.Maybe             (catMaybes, fromMaybe, isJust)+import           Data.Text              (Text)+import qualified Data.Text              as T+import           Data.Text.Encoding     (decodeUtf8)+import           Data.Time.Clock.POSIX  (POSIXTime, getPOSIXTime)++import           Network.Hawk.Server.Types+import qualified Network.Iron           as Iron+import           Network.Oz.JSON+import           Network.Oz.Types++-- | When the user authorizes the application access request, the+-- server issues an /rsvp/ which is an encoded string containing the+-- application identifier, the grant identifier, and an expiration.+--+-- This function generates the /rsvp/ string.+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)+  where+    envelope now = OzTicket+                   { ozTicketExp = now + ticketOptsRsvpTtl+                   , ozTicketApp = app+                   , ozTicketGrant = grant+                   , ozTicketUser = Nothing+                   , ozTicketScope = []+                   , ozTicketDelegate = False+                   , ozTicketDlg = Nothing+                   }++-- | Issues a new application or user ticket.+issue :: MonadIO m => Key -> OzApp -> Maybe OzGrant -> TicketOpts -> m (Either String OzSealedTicket)+issue p app mgrant opts = case checkGrant app mgrant of+                            Right scope -> issueTicket p mgrant+                                           (fromMaybe [] scope)+                                           (ozAppId app)+                                           Nothing True opts+                            Left e -> return (Left e)+  where+    checkGrant _ Nothing = Right Nothing+    checkGrant OzApp{..} (Just OzGrant{..}) = checkGrantScope ozAppScope ozGrantScope -- fixme: what else to check?++-- | Generates a ticket without any checking+issueTicket :: MonadIO m => Key -> Maybe OzGrant -> OzScope -> OzAppId+            -> Maybe OzAppId -> Bool -> TicketOpts+            -> m (Either String OzSealedTicket)+issueTicket p mgrant scope app dlg delegate opts = do+  exp <- getExpiry opts mgrant+  let ticket = OzTicket { ozTicketExp = exp+                        , ozTicketApp = app+                        , ozTicketScope = scope+                        , ozTicketGrant = ozGrantId <$> mgrant+                        , ozTicketUser = ozGrantUser <$> mgrant+                        , ozTicketDlg = dlg+                        , ozTicketDelegate = ticketOptsDelegate opts && delegate+                        }+  res <- liftIO $ generateTicket opts p ticket+  return $ maybe (Left "Could not issue ticket") Right res+++-- | Reissues an application or user ticket.+reissue :: MonadIO m => Key -> OzApp -> Maybe OzGrant+        -> TicketOpts -> Maybe OzScope -> Maybe OzAppId+        -> OzSealedTicket -> m (Either String OzSealedTicket)+reissue p app mgrant opts@TicketOpts{..} mscope issueTo t = case checks of+    Right () -> issueTicket p mgrant+      (fromMaybe ozTicketScope mscope)+      (fromMaybe ozTicketApp issueTo)+      (issueTo <|> ozTicketDlg)+      ozTicketDelegate+      opts'+    Left e -> return (Left e)+  where+    checks :: Either String ()+    checks = do+      void $ checkParentScope (Just ozTicketScope) mscope+      when (ticketOptsDelegate && not ozTicketDelegate)+        $ Left "Cannot override ticket delegate restriction"+      when (isJust issueTo) $ do+        when (isJust ozTicketDlg) $ Left "Cannot re-delegate" -- fixme: http bad request+        when (not ozTicketDelegate) $ Left "Ticket does not allow delegation"+      when (ozTicketGrant /= fmap ozGrantId mgrant) $+        Left "Parent ticket grant does not match options.grant"++    OzTicket{..} = ozTicket t++    opts' = if ticketOptsExt == mempty && not (null (ozTicketExt t))+      then opts { ticketOptsExt = OzExt (ozTicketExt t) mempty }+      else opts+++getExpiry :: MonadIO m => TicketOpts -> Maybe OzGrant -> m POSIXTime+getExpiry opts mgrant = do+  now <- liftIO getPOSIXTime+  return $ calc (ticketOptsTicketTtl opts) mgrant now+  where+    calc ttl mgrant now = maybe id (min . ozGrantExp) mgrant (now + ttl)++-- | Probably not a worthy function+checkPassword :: Key -> Either String ()+checkPassword (Key p) | BS.null p = Left "Invalid encryption password"+                      | otherwise = Right ()++-- | 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)+  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)+  where msg = "New scope is not a subset of the parent ticket scope"++checkScopes :: Maybe OzScope -> Maybe OzScope -> Either String (Maybe OzScope)+checkScopes Nothing    Nothing       = Right Nothing+checkScopes Nothing    (Just _)      = Left ""+checkScopes (Just big) Nothing       = Just <$> checkScope big+checkScopes (Just big) (Just little) | isInfixOf little big = Just <$> checkScope little+                                     | otherwise = Left "not a subset"++-- | Validate scope array strings.+checkScope :: OzScope -> Either String OzScope+checkScope scope | any T.null scope = Left "scope includes empty string value"+                 | 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+  drg <- getSystemDRG+  return (fst $ withRandomBytes drg ticketOptsKeyBytes base64)++base64 :: ByteString -> ByteString+base64 = Iron.urlSafeBase64 . B64.encode++-- | Adds the cryptographic properties to a ticket and prepares it for+-- sending.+generateTicket :: TicketOpts -> Key -> OzTicket -> IO (Maybe OzSealedTicket)+generateTicket opts@TicketOpts{..} (Key p) t = do+  key <- randomKey opts+  let Object ext = toJSON ticketOptsExt+  let sealed = OzSealedTicket t (Key key) ticketOptsHmacAlgorithm ext ""+  mid <- Iron.sealWith ticketOptsIron (Iron.password p) sealed+  return (finishSeal ticketOptsExt sealed <$> mid)++-- | Removes the private ext part and adds the ticket ID.+finishSeal :: OzExt -> OzSealedTicket -> ByteString -> OzSealedTicket+finishSeal ext ticket ticketId = ticket { ozTicketId = decodeUtf8 ticketId+                                        , ozTicketExt = ozExtPublic ext+                                        }++-- | 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+  where lookup = Iron.onePassword p

@@ -0,0 +1,195 @@+{-# LANGUAGE DeriveGeneric #-}++module Network.Oz.Types+  ( OzTicket(..)+  , OzSealedTicket(..)+  , OzApp(..)+  , OzGrant(..)+  , OzExt(..)+  , TicketOpts(..)+  , defaultTicketOpts++  , OzAppId+  , OzUserId+  , OzGrantId+  , OzPermission+  , OzScope+  , OzTicketId++  , OzLoadApp+  , OzLoadGrant++  , Endpoints(..)+  , defaultEndpoints+  ) where++import           Crypto.Hash.Algorithms (SHA256 (..))+import           Data.Aeson             (Object)+import           Data.ByteString        (ByteString)+import           Data.Text              (Text)+import           Data.Time.Clock        (NominalDiffTime)+import           Data.Time.Clock.POSIX  (POSIXTime)+import           GHC.Generics+import           Data.Default           (Default(..))++import           Network.Hawk           (HawkAlgo)+import           Network.Hawk.Types+import qualified Network.Iron           as Iron (Options(..))++-- | Identifies an Oz Application+type OzAppId = Text+-- | Identifies a user+type OzUserId = Text+-- | Identifies an Oz grant+type OzGrantId = Text+-- | Tag representing permissions of application+type OzPermission = Text+-- | Set of permissions for application+type OzScope = [OzPermission]+-- | Oz ticket identifier, which is also a 'Network.Iron' encrypted+-- version of the ticket.+type OzTicketId = Text++-- | An object describing an application.+data OzApp = OzApp+  { ozAppId        :: OzAppId  -- ^ The application identifier++  -- | An array with the default application scope.+  , ozAppScope     :: Maybe OzScope+  -- | If true, the application is allowed to delegate a+  -- ticket to another application. Defaults to false.+  , ozAppDelegate  :: Bool+  -- | The shared secret used to authenticate.+  , ozAppKey       :: Key+  -- | The HMAC algorithm used to authenticate.+  , ozAppAlgorithm :: HawkAlgo+  } deriving (Show, Generic)++-- | A grant is the authorization given to an application by a user to+-- access the user's protected resources. Grants can be persisted in a+-- database (usually to support revocation) or can be self describing+-- (using an encoded identifier).+data OzGrant = OzGrant+  { ozGrantId    :: OzGrantId  -- ^ The grant identifier++  -- | The application identifier.+  , ozGrantApp   :: OzAppId+  -- | The user identifier.+  , ozGrantUser  :: OzUserId+  -- | Grant expiration time+  , ozGrantExp   :: POSIXTime+  -- | An array with the scope granted by the user to the application.+  , ozGrantScope :: Maybe OzScope+  } deriving (Show, Generic)++-- | An object used to include custom server data in the ticket and+-- response. The public part is included in the Oz reponse under+-- ticket.ext. The private part is only available within the encoded+-- ticket.+data OzExt = OzExt+             { ozExtPublic  :: Object -- ^ Public ext; included in response+             , ozExtPrivate :: Object -- ^ Private ext; only in encoded ticket.+             } deriving (Show, Eq, Generic)++instance Monoid OzExt where+  mempty = OzExt mempty mempty+  mappend (OzExt a b) (OzExt c d) = OzExt (mappend a c) (mappend b d)++-- | A sealed ticket is the result of 'Network.Oz.Ticket.issue'. It is+-- JSON-encoded and given to the app.+--+-- Unlike most Hawk credential identifiers, the Oz ticket identifier+-- is an encoded Iron string which when decoded contains an 'OzTicket'+data OzSealedTicket = OzSealedTicket+  { ozTicket          :: OzTicket+  , ozTicketKey       :: Key -- ^ A shared secret used to authenticate.+  , ozTicketAlgorithm :: HawkAlgo -- ^ The HMAC algorithm used to authenticate (e.g. HMAC-SHA256).+  , ozTicketExt       :: Object -- ^ Custom server public data attached to the ticket.+  , ozTicketId        :: OzTicketId  -- ^ The ticket identifier used for making authenticated Hawk requests.+  } deriving (Show, Generic)++-- | An object describing a ticket and its public properties.  An Oz+-- ticket is a set of Hawk credentials used by the application to+-- access protected resources. Just like any other Hawk credentials.+data OzTicket = OzTicket {+  -- | Ticket expiration time.+    ozTicketExp      :: POSIXTime+  -- | The application id the ticket was issued to.+  , ozTicketApp      :: OzAppId++  -- | The user id if the ticket represents access to+  -- user resources. If no user id is included, the+  -- ticket allows the application access to the+  -- application own resources only.+  , ozTicketUser     :: Maybe OzUserId+  -- | The ticket scope. Defaults to @[]@ if no scope is+  -- specified.+  , ozTicketScope    :: OzScope+  -- | If user is set, includes the grant identifier+  -- referencing the authorization granted by the user+  -- to the application. Can be a unique identifier or+  -- string encoding the grant information as long as+  -- the server is able to parse the information later.+  , ozTicketGrant    :: Maybe OzGrantId+  -- | If false, the ticket cannot be delegated+  -- regardless of the application permissions. Defaults+  -- to true which means use the application permissions+  -- to delegate.+  , ozTicketDelegate :: Bool+  -- | If the ticket is the result of access delegation,+  -- the application id of the delegating application.+  , ozTicketDlg      :: Maybe OzAppId+  } deriving (Show, Generic)+++-- | Ticket generation options. The default values are:+--+--     * One hour ticket lifetime.+--     * One minute RSVP lifetime.+--     * Use the application permissions to delegate.+--     * 'Network.Iron.defaults' Iron configuration.+--     * 32 byte Hawk key length.+--     * 'Crypto.Hash.Algorithms.SHA256' message authentication.+--     * No ext data.++data TicketOpts = TicketOpts+  { ticketOptsTicketTtl     :: NominalDiffTime -- ^ Ticket lifetime+  , ticketOptsRsvpTtl       :: NominalDiffTime -- ^ RSVP lifetime++  -- | If false, the ticket cannot be delegated+  -- regardless of the application+  -- permissions.+  , ticketOptsDelegate      :: Bool+  -- | Overrides the default Iron configuration.+  , ticketOptsIron          :: Iron.Options+  -- | The Hawk key length in bytes.+  , ticketOptsKeyBytes      :: Int+  -- | The Hawk HMAC algorithm.+  , ticketOptsHmacAlgorithm :: HawkAlgo+  -- | Custom server data to be included in the ticket.+  , ticketOptsExt           :: OzExt+  }++defaultTicketOpts :: TicketOpts+defaultTicketOpts = TicketOpts 3600 60 True def 32 (HawkAlgo SHA256) mempty++instance Default TicketOpts where+  def = defaultTicketOpts++-- | User-supplied function to look up an Oz app definition by its+-- identifier.+type OzLoadApp = OzAppId -> IO (Either String OzApp)++-- | User-supplied function to look up an Oz grant by its identifier.+type OzLoadGrant = OzGrantId -> IO (Either String (OzGrant, Maybe OzExt))++-- | Describes the URL configuration of the Oz server.+data Endpoints = Endpoints+  { endpointApp     :: Text+  , endpointReissue :: Text+  , endpointRsvp    :: Text+  } deriving Show++-- | A normal set of endpoint URL paths.+defaultEndpoints :: Endpoints+defaultEndpoints = Endpoints "/oz/app" "/oz/reissue" "/oz/rsvp"

@@ -0,0 +1,14 @@+module Main where++import           Test.Tasty (defaultMain, testGroup)++import qualified Network.Iron.Tests+import qualified Network.Hawk.Tests+import qualified Network.Oz.Tests++main :: IO ()+main = defaultMain $ testGroup "Tests"+    [ Network.Iron.Tests.tests+    , Network.Hawk.Tests.tests+    , Network.Oz.Tests.tests+    ]

@@ -0,0 +1,142 @@+{-# LANGUAGE RecordWildCards #-}++module Network.Hawk.Tests (tests) where++import Data.Either (isRight)+import Data.Default+import Data.ByteString (ByteString)+import Network.Wai (Request(..), defaultRequest)+import Network.HTTP.Client (Response(..))+import Network.HTTP.Client.Internal (Response(..))+import Network.HTTP.Types.Status (ok200)+import Data.Text.Encoding (decodeUtf8)++import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (testCase)+import Test.HUnit (Assertion, (@?=), (@?))++import Network.Hawk+import Network.Hawk.Server.Types (HawkReq(..), AuthSuccess(..))+import qualified Network.Hawk.Client as Client+import qualified Network.Hawk.Server as Server+import qualified Network.Hawk.Client.Types as Client (HeaderArtifacts(..))+import qualified Network.Hawk.Server.Types as Server (HeaderArtifacts(..))++tests :: TestTree+tests = testGroup "Network.Hawk"+        [ testCase "generates a header then successfully parses it" test01+        --, testCase "generates a header then successfully parses it (WAI request)" test02+        , testCase "generates a header then successfully parses it (absolute request uri)" test03+        ]++makeCreds :: Client.ClientId -> (Client.Credentials, Server.CredentialsFunc IO String)+makeCreds i = (cc, \i -> return sc)+  where+    cc = Client.Credentials i key algo+    sc = Right (Server.Credentials key algo, user)+    key = "werxhqb98rpaxn39848xrunpaw3489ruxnpa98w4rxn"+    algo = if i == "1" then HawkAlgo SHA1 else HawkAlgo SHA256+    user = "steve"++test01 :: Assertion+test01 = do+  let (creds, credsFunc) = makeCreds "123456"+      ext = Just "some-app-data"+  hdr <- Client.header "http://example.com:8080/resource/4?filter=a" "GET" creds Nothing ext+  let hrq = def+            { hrqUrl = "/resource/4?filter=a"+            , hrqHost = "example.com"+            , hrqPort = Just 8080+            , hrqAuthorization = Client.hdrField hdr+            }+  r <- Server.authenticate def credsFunc hrq+  isRight r @?= True+  let Right (Server.AuthSuccess creds' arts user) = r+  user @?= "steve"+  Server.shaExt arts @?= Just "some-app-data"++-- generates a header then successfully parse it (WAI request)+test02 :: Assertion+test02 = do+  -- Generate client header+  let (creds, credsFunc) = makeCreds "123456"+      ext = Just "some-app-data"+      payload = PayloadInfo "text/plain;x=y" "some not so random text"+  hdr <- Client.header "http://example.com:8080/resource/4?filter=a" "POST" creds (Just payload) ext++  -- Server verifies client request+  let req = defaultRequest+        { requestMethod = "POST"+        , rawPathInfo = "/resource/4"+        , rawQueryString = "?filter=a"+        , requestHeaders = [("host", "example.com:8080"),+                            ("content-type", "text/plain;x=y"),+                            ("authorization", Client.hdrField hdr)]+        }+  r <- Server.authenticateRequest def credsFunc req (Just (payloadData payload))+  -- fixme: Left "Bad mac"+  isRight r @? "Expected auth success, got: " ++ show r+  let Right s@(Server.AuthSuccess creds2 arts user) = r+  user @?= "steve"+  Server.shaExt arts @?= Just "some-app-data"+  Server.authenticatePayload s payload @?= Right ()++  -- Client verifies server response+  let payload2 = PayloadInfo "text/plain" "Some reply"+      hdr2 = Server.header creds2 arts (Just payload2)+      res = Response+        { responseStatus = ok200+        , responseHeaders = [hdr2, ("content-type", payloadContentType payload2)]+        , responseBody = payloadData payload2+        , responseVersion = undefined+        , responseCookieJar = undefined+        , responseClose' = undefined+        }+      creds2' = clientCreds "" creds2+      arts' = clientHeaderArtifacts arts+  r2 <- Client.authenticate res creds2' arts' (Just (payloadData payload2)) Client.ServerAuthorizationRequired+  r2 @?= Right ()++clientCreds :: ClientId -> Server.Credentials -> Client.Credentials+clientCreds i (Server.Credentials k a) = Client.Credentials i k a++-- fixme: there's possibly a case for merging these two types+-- server artifacts have header mac and client id+-- dlg is text/bytestring+clientHeaderArtifacts :: Server.HeaderArtifacts -> Client.HeaderArtifacts+clientHeaderArtifacts Server.HeaderArtifacts{..} = Client.HeaderArtifacts+  { chaTimestamp = shaTimestamp+  , chaNonce     = shaNonce+  , chaMethod    = shaMethod+  , chaHost      = shaHost+  , chaPort      = shaPort+  , chaResource  = shaResource+  , chaHash      = shaHash+  , chaExt       = shaExt+  , chaApp       = shaApp+  , chaDlg       = decodeUtf8 <$> shaDlg+  -- , shaId        :: ClientId+  -- , shaMac       :: ByteString+  }++-- generates a header then successfully parse it (absolute request uri)+test03 :: Assertion+test03 = do+  let (creds, credsFunc) = makeCreds "123456"+      ext = Just "some-app-data"+      payload = PayloadInfo "text/plain;x=y" "some not so random text"+  hdr <- Client.header "http://example.com:8080/resource/4?filter=a" "POST" creds (Just payload) ext+  let hrq = def+            { hrqMethod = "POST"+            , hrqUrl = "/resource/4?filter=a" -- fixme: not absolute+            , hrqHost = "example.com"+            , hrqPort = Just 8080+            , hrqAuthorization = Client.hdrField hdr+            , hrqPayload = Nothing+            }+  r <- Server.authenticate def credsFunc hrq+  isRight r @? "Expected auth success, got: " ++ show r+  let Right s@(Server.AuthSuccess creds' arts user) = r+  user @?= "steve"+  Server.shaExt arts @?= Just "some-app-data"+  Server.authenticatePayload s payload @?= Right ()

@@ -0,0 +1,287 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE BangPatterns               #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}+{-# LANGUAGE Rank2Types #-}++module Network.Iron.Tests (tests) where++import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as S8+import Data.Maybe (fromJust)+import Data.Either (isLeft)+import Data.Aeson+import Data.Time.Clock (NominalDiffTime)+import Data.Default (def)++import Test.QuickCheck+import Test.QuickCheck.Monadic+import qualified Test.QuickCheck         as QC+import qualified Test.QuickCheck.Monadic as QC+import           Test.Tasty              (TestTree, testGroup)+import           Test.Tasty.HUnit        (testCase)+import           Test.Tasty.QuickCheck   (testProperty)+import           Test.HUnit              (Assertion, (@?=))++import Network.Iron++tests :: TestTree+tests = testGroup "Network.Iron"+    [ testProperty "seal . unseal == id -- many different options"+      (prop_test :: Test1 Object -> Property)+    , testProperty "seal . unseal == id -- default options" prop_test1+    , testProperty "seal . unseal == id -- expiration" prop_test2+    , testProperty "seal . unseal == id -- expiration and many different options"+      (prop_test3 :: Test1 Object -> Property)+    , testProperty "unseal fails when password not found"+      (prop_test4 :: Test1 Object -> Property)++    , testGroup "Seal"+      [ testCase "returns an error when password.id is invalid" testSeal01+      -- , testCase "returns an error when password is missing" testSeal02  -- fixme: enable+      ]+    , testGroup "Unseal"+      [ testCase "unseals a ticket" testUnseal01+      , testCase "returns an error when number of sealed components is wrong" testUnseal02+      , testCase "returns an error when mac prefix is wrong" testUnseal03+      , testCase "returns an error when integrity check fails" testUnseal04+      , testCase "returns an error when decryption fails" testUnseal05+      , testCase "returns an error when iv base64 decoding fails" testUnseal06+      , testCase "returns an error when decrypted object is invalid" testUnseal07+      , testCase "returns an error when expired" testUnseal08+      , testCase "returns an error when expiration NaN" testUnseal09+      ]+    ]++obj :: Object+obj = fromJust $ decode "{\"a\":1,\"d\":{\"e\":\"f\"},\"b\":2,\"c\":[3,4,5]}"++testPassword :: ByteString+testPassword = "some_not_random_password_that_is_also_long_enough"++defaultPassword :: Password+defaultPassword = makeOnePassword testPassword++makeOnePassword :: ByteString -> Password+makeOnePassword = fromJust . passwordWithId "default"++lookupPassword :: LookupPassword+lookupPassword = onePassword testPassword++instance Arbitrary NominalDiffTime where+  arbitrary = do+    n <- choose (0, 3600 * 24) :: Gen Double+    return $ realToFrac n++instance Arbitrary Object where+  arbitrary = pure obj++instance Arbitrary Password where+  arbitrary = do+    p1 <- arbitrary :: Gen ByteString+    p2 <- arbitrary+    pid <- arbitraryPasswordId+    n <- choose (1, 4) :: Gen Int+    -- fixme: add pre-generated keys of 128/256 bit lengths+    return $ case n of+      1 -> password p1+      2 -> passwords p1 p2+      3 -> fromJust $ passwordWithId pid p1+      4 -> fromJust $ passwordsWithId pid p1 p2++onePassword' :: Password -> LookupPassword+onePassword' = const . Just++arbitraryPasswordId :: Gen PasswordId+arbitraryPasswordId = do+  cs <- listOf1 (elements $ ['a'..'z'] ++ ['0'..'9'] ++ ['A'..'Z'] ++ ['_'])+  return $ S8.pack cs++instance Arbitrary ByteString where+    arbitrary = fmap S8.pack arbitrary++instance Arbitrary Options where+  arbitrary = Options <$> arbitrary <*> arbitrary <*> ttl <*> skew <*> offset+    where+      ttl = oneof [arbitrary, pure 0]+      skew = pure 0+      offset = pure 0++instance Arbitrary EncryptionOpts where+  arbitrary = EncryptionOpts <$> arbitrary <*> arbitrary <*> choose (1, 3) <*> pure Nothing++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 IronCipher where+  arbitrary = oneof (map pure [AES128CTR, AES256CBC])++instance Arbitrary IronMAC where+  arbitrary = pure (IronMAC SHA256)++data Test1 a = Test1+  { test1Obj :: a+  , test1Opts :: Options+  , test1Password :: Password+  } deriving Show++instance Arbitrary a => Arbitrary (Test1 a) where+  arbitrary = Test1 <$> arbitrary <*> arbitrary <*> arbitrary++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+    return m+  assert (obj' == obj)++-- 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+  assert (obj' == Right obj)++-- unseal and sealed object with expiration+prop_test2 :: NominalDiffTime -> Property+prop_test2 ttl = monadicIO $ do+  let opts = def { ironTTL = ttl }+  obj' <- run $ do+    Just s <- sealWith opts defaultPassword obj+    unseal lookupPassword s+  assert (obj' == Right obj)++-- unseal and sealed object with expiration and time offset+prop_test3 :: (ToJSON a, FromJSON a, Eq a) => Test1 a -> Property+prop_test3 Test1{..} = monadicIO $ do+  let testTTL = max 1 (ironTTL test1Opts)+      opts = test1Opts+             { ironLocaltimeOffset = negate (testTTL + 100)+             , ironTTL = testTTL }+  mobj' <- run $ do+    Just s <- sealWith opts test1Password test1Obj+    unseal (onePassword' test1Password) s+  assert (testTTL == 0 || isErr mobj')+  assert (testTTL /= 0 || mobj' == Right test1Obj)++isErr :: Either String a -> Bool+isErr = isLeft++-- fixme: following tests need iron api to accept pre-generated keys+-- [ ] turns object into a ticket than parses the ticket successfully (password buffer)+-- [ ] fails to turns object into a ticket (password buffer too short)++-- [X] turns object into a ticket than parses the ticket successfully (password object)+-- [X] handles separate password buffers (password object)+-- [?] handles a common password buffer (password object)++-- fails to parse a sealed object when password not found+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)+  assert (mobj' == Left "Cannot find password: default")++-- ## generateKey++-- many cases are impossible because of the construction of types.++-- [/] returns an error when password is missing+-- [/] returns an error when password is too short+-- [/] returns an error when options are missing+-- [/] returns an error when an unknown algorithm is specified++-- fixme: add options error handling to getSealStuff+-- [ ] returns an error when no salt or salt bits are provided+-- [ ] returns an error when invalid salt bits are provided+-- fixme: can haskell DRG fail?+-- [ ] returns an error when Cryptiles.randomBits fails+-- fixme: PBKDF2.generate is a pure function, is it total?+-- [ ] returns an error when Crypto.pbkdf2 fails++-- ## encrypt+-- [/] returns an error when password is missing -- impossible by construction+-- ## decrypt+-- [/] returns an error when password is missing++-- ## hmacWithPassword+-- [/] returns an error when password is missing+-- [~] produces the same mac when used with buffer password++-- ## seal+-- [/] returns an error when password is missing+-- [/] returns an error when integrity options are missing++-- returns an error when password.id is invalid+testSeal01 :: Assertion+testSeal01 = passwordWithId "asd$" ("asd" :: ByteString) @?= Nothing++testSeal02 :: Assertion+-- returns an error when password is missing+testSeal02 = Just (password ("" :: ByteString)) @?= Nothing+++-- ## unseal++ticket01, ticket02, ticket03, ticket04 :: ByteString+ticket01 = "Fe26.2**0cdd607945dd1dffb7da0b0bf5f1a7daa6218cbae14cac51dcbd91fb077aeb5b*aOZLCKLhCt0D5IU1qLTtYw*g0ilNDlQ3TsdFUqJCqAm9iL7Wa60H7eYcHL_5oP136TOJREkS3BzheDC1dlxz5oJ**05b8943049af490e913bbc3a2485bee2aaf7b823f4c41d0ff0b7c168371a3772*R8yscVdTBRMdsoVbdDiFmUL8zb-c3PQLGJn4Y8C-AqI"+ticket02 = "x*Fe26.2**a6dc6339e5ea5dfe7a135631cf3b7dcf47ea38246369d45767c928ea81781694*D3DLEoi-Hn3c972TPpZXqw*mCBhmhHhRKk9KtBjwu3h-1lx1MHKkgloQPKRkQZxpnDwYnFkb3RqdVTQRcuhGf4M**ff2bf988aa0edf2b34c02d220a45c4a3c572dac6b995771ed20de58da919bfa5*HfWzyJlz_UP9odmXvUaVK1TtdDuOCaezr-TAg2GjBCU"+ticket03 = "Fe27.2**a6dc6339e5ea5dfe7a135631cf3b7dcf47ea38246369d45767c928ea81781694*D3DLEoi-Hn3c972TPpZXqw*mCBhmhHhRKk9KtBjwu3h-1lx1MHKkgloQPKRkQZxpnDwYnFkb3RqdVTQRcuhGf4M**ff2bf988aa0edf2b34c02d220a45c4a3c572dac6b995771ed20de58da919bfa5*HfWzyJlz_UP9odmXvUaVK1TtdDuOCaezr-TAg2GjBCU"+ticket04 = "Fe26.2**b3ad22402ccc60fa4d527f7d1c9ff2e37e9b2e5723e9e2ffba39a489e9849609*QKCeXLs6Rp7f4LL56V7hBg*OvZEoAq_nGOpA1zae-fAtl7VNCNdhZhCqo-hWFCBeWuTTpSupJ7LxQqzSQBRAcgw**72018a21d3fac5c1608a0f9e461de0fcf17b2befe97855978c17a793faa01db1*Qj53DFE3GZd5yigt-mVl9lnp0VUoSjh5a5jgDmod1EZ"++-- unseals a ticket+testUnseal01 :: Assertion+testUnseal01 = do+  r <- unseal 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 @?= Left msg++-- returns an error when number of sealed components is wrong+testUnseal02 :: Assertion+testUnseal02 = unsealFail ticket02 "Incorrect number of sealed components"++-- [/] returns an error when password is missing++-- returns an error when mac prefix is wrong+testUnseal03 :: Assertion+testUnseal03 = unsealFail ticket03 "Wrong mac prefix"++-- returns an error when integrity check fails+testUnseal04 :: Assertion+testUnseal04 = unsealFail ticket04 "Bad hmac value"++-- returns an error when decryption fails+testUnseal05 :: Assertion+testUnseal05 = unsealFail ticket "base64: 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"+  where ticket = "Fe26.2**a6dc6339e5ea5dfe7a135631cf3b7dcf47ea38246369d45767c928ea81781694*D3DLEoi-Hn3c972TPpZXqw??*mCBhmhHhRKk9KtBjwu3h-1lx1MHKkgloQPKRkQZxpnDwYnFkb3RqdVTQRcuhGf4M**ff2bf988aa0edf2b34c02d220a45c4a3c572dac6b995771ed20de58da919bfa5*iF6pSFeSD8iYRlYIfD6VRwADFjFR3fX6hM_kIjN3_ew"++-- returns an error when decrypted object is invalid+testUnseal07 :: Assertion+testUnseal07 = unsealFail ticket "Error in $: Failed reading: satisfy"+  where ticket = "Fe26.2**2e7f52699752d2e9325097a1ddbb6e39b22f21a9e354989a681e004445cec66b*aRq0dy_f-_jWIisjiugZKw*byjIKZvNBwaCd2epZ9CIdw**19f2010b44cd3736b3acaf81181a453830778ebdc9c418f91dfd1812eb761730*5_b7lBEkLLQJ6awNQ75Q3QHbPP89kCPfdYqP43Eylss"++-- returns an error when expired+testUnseal08 = unsealFail ticket "Expired seal"+  where ticket = "Fe26.2**a38dc7a7bf2f8ff650b103d8c669d76ad219527fbfff3d98e3b30bbecbe9bd3b*nTsatb7AQE1t0uMXDx-2aw*uIO5bRFTwEBlPC1Nd_hfSkZfqxkxuY1EO2Be_jJPNQCqFNumRBjQAl8WIKBW1beF*1380495854060*e4fe33b6dc4c7ef5ad7907f015deb7b03723b03a54764aceeb2ab1235cc8dce3*yE0dHH22wy4N9z_djofZNhja9l7rDLuq6H24HBswSp0"++-- returns an error when expiration NaN+testUnseal09 = unsealFail ticket "Invalid expiration"+  where ticket = "Fe26.2**a38dc7a7bf2f8ff650b103d8c669d76ad219527fbfff3d98e3b30bbecbe9bd3b*nTsatb7AQE1t0uMXDx-2aw*uIO5bRFTwEBlPC1Nd_hfSkZfqxkxuY1EO2Be_jJPNQCqFNumRBjQAl8WIKBW1beF*a*e4fe33b6dc4c7ef5ad7907f015deb7b03723b03a54764aceeb2ab1235cc8dce3*yTXLwJ3XDHC0gRNR3J5xxIvkHovPZEa5auw6voFT6b8"

@@ -0,0 +1,8 @@+module Network.Oz.Tests (tests) where++import Test.Tasty (TestTree, testGroup)++import Network.Oz++tests :: TestTree+tests = testGroup "Network.Oz" [ ]