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
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
}
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
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
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"
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)
checkPassword :: Key -> Either String ()
checkPassword (Key p) | BS.null p = Left "Invalid encryption password"
| otherwise = Right ()
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"
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
drg <- getSystemDRG
return (fst $ withRandomBytes drg ticketOptsKeyBytes base64)
base64 :: ByteString -> ByteString
base64 = Iron.urlSafeBase64 . B64.encode
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)
finishSeal :: OzExt -> OzSealedTicket -> ByteString -> OzSealedTicket
finishSeal ext ticket ticketId = ticket { ozTicketId = decodeUtf8 ticketId
, ozTicketExt = ozExtPublic ext
}
parse :: TicketOpts -> Key -> ByteString -> IO (Either String OzSealedTicket)
parse TicketOpts{..} (Key p) = Iron.unsealWith ticketOptsIron lookup
where lookup = Iron.onePassword p