{-# 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           Data.Bifunctor         (first)
import           Crypto.Random
import           Data.Aeson             (Object (..), Value (..), object,
                                         toJSON)
import           Data.ByteString        (ByteString)
import qualified Data.ByteString        as BS
import qualified Data.ByteArray.Encoding as B (Base (..), convertToBase, convertFromBase)
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
import           Network.Hawk.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.seal 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 = first (const msg) (checkScopes app grant)
  where msg = "Grant scope is not a subset of the application scope"

checkParentScope :: Maybe OzScope -> Maybe OzScope -> Either String (Maybe OzScope)
checkParentScope parent scope = first (const msg) (checkScopes parent scope)
  where msg = "New scope is not a subset of the parent ticket scope"

checkScopes :: Maybe OzScope -> Maybe OzScope -> Either String (Maybe OzScope)
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

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 = B.convertToBase B.Base64URLUnpadded

-- | 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.seal 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.unseal ticketOptsIron lookup
  where lookup = Iron.onePassword p