diohsc-0.1.3: ActiveIdentities.hs

-- This file is part of Diohsc
-- Copyright (C) 2020 Martin Bays <mbays@sdf.org>
--
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of version 3 of the GNU General Public License as
-- published by the Free Software Foundation, or any later version.
--
-- You should have received a copy of the GNU General Public License
-- along with this program.  If not, see http://www.gnu.org/licenses/.

{-# LANGUAGE TupleSections #-}

module ActiveIdentities where

import           Control.Monad  (mplus)
import           Data.Hourglass (Elapsed (..))
import           Data.Maybe     (fromJust)
import           Time.System    (timeCurrent)

import qualified Data.Map       as Map

import           Identity       (Identity (..), isTemporary, showIdentity)
import           Prompt
import           Request
import           URI

type ActiveIdentities = Map.Map Request (Identity, Elapsed)

insertIdentity :: Request -> Identity -> ActiveIdentities -> IO ActiveIdentities
insertIdentity (NetworkRequest host uri) ident ais = do
    let req = NetworkRequest host $ stripUri uri
    currentTime <- timeCurrent
    return $ Map.insert req (ident, currentTime) ais
insertIdentity _ _ ais = return ais

deleteIdentity :: Request -> ActiveIdentities -> ActiveIdentities
deleteIdentity = Map.delete

findIdentityRoot :: ActiveIdentities -> Request -> Maybe (Request, (Identity, Elapsed))
findIdentityRoot ais (NetworkRequest host reqUri) = findIdentity' $ stripUri reqUri
    where findIdentity' uri =
            let req = NetworkRequest host uri
                uri' = stripUri $ (fromJust . parseUriReference $ ".") `relativeTo` uri
            in ((req,) <$> Map.lookup req ais) `mplus`
                if uri' == uri then Nothing else findIdentity' uri'
findIdentityRoot _ _ = Nothing

findIdentity :: ActiveIdentities -> Request -> Maybe Identity
findIdentity ais req = fst . snd <$> findIdentityRoot ais req

useActiveIdentity :: Bool -> Bool -> Request -> ActiveIdentities -> IO (Maybe Identity, ActiveIdentities)
useActiveIdentity noConfirm ansi req ais =
    case findIdentityRoot ais req of
        Nothing -> return (Nothing, ais)
        Just (root, (ident, lastUsed)) -> do
            currentTime <- timeCurrent
            use <- if currentTime - lastUsed > Elapsed 1800
                then promptYN (not noConfirm) False $ if isTemporary ident
                    then "Reuse old anonymous identity?"
                    else "Continue to use identity " ++ showIdentity ansi ident ++ "?"
                else return True
            return $ if use
                then (Just ident, Map.insert root (ident, currentTime) ais)
                else (Nothing, Map.delete root ais)