ActiveIdentities.hs

   1 -- This file is part of Diohsc
   2 -- Copyright (C) 2020 Martin Bays <mbays@sdf.org>
   3 --
   4 -- This program is free software: you can redistribute it and/or modify
   5 -- it under the terms of version 3 of the GNU General Public License as
   6 -- published by the Free Software Foundation, or any later version.
   7 --
   8 -- You should have received a copy of the GNU General Public License
   9 -- along with this program.  If not, see http://www.gnu.org/licenses/.
  10
  11 {-# LANGUAGE TupleSections #-}
  12
  13 module ActiveIdentities where
  14
  15 import           Control.Monad  (mplus)
  16 import           Data.Hourglass (Elapsed (..))
  17 import           Data.Maybe     (fromJust)
  18 import           Time.System    (timeCurrent)
  19
  20 import qualified Data.Map       as Map
  21
  22 import           Identity       (Identity (..), isTemporary, showIdentity)
  23 import           Prompt
  24 import           Request
  25 import           URI
  26
  27 type ActiveIdentities = Map.Map Request (Identity, Elapsed)
  28
  29 insertIdentity :: Request -> Identity -> ActiveIdentities -> IO ActiveIdentities
  30 insertIdentity (NetworkRequest host uri) ident ais = do
  31     let req = NetworkRequest host $ stripUri uri
  32     currentTime <- timeCurrent
  33     return $ Map.insert req (ident, currentTime) ais
  34 insertIdentity _ _ ais = return ais
  35
  36 deleteIdentity :: Request -> ActiveIdentities -> ActiveIdentities
  37 deleteIdentity = Map.delete
  38
  39 findIdentityRoot :: ActiveIdentities -> Request -> Maybe (Request, (Identity, Elapsed))
  40 findIdentityRoot ais (NetworkRequest host reqUri) = findIdentity' $ stripUri reqUri
  41     where findIdentity' uri =
  42             let req = NetworkRequest host uri
  43                 uri' = stripUri $ (fromJust . parseUriReference $ ".") `relativeTo` uri
  44             in ((req,) <$> Map.lookup req ais) `mplus`
  45                 if uri' == uri then Nothing else findIdentity' uri'
  46 findIdentityRoot _ _ = Nothing
  47
  48 findIdentity :: ActiveIdentities -> Request -> Maybe Identity
  49 findIdentity ais req = fst . snd <$> findIdentityRoot ais req
  50
  51 useActiveIdentity :: Bool -> Bool -> Request -> ActiveIdentities -> IO (Maybe Identity, ActiveIdentities)
  52 useActiveIdentity noConfirm ansi req ais =
  53     case findIdentityRoot ais req of
  54         Nothing -> return (Nothing, ais)
  55         Just (root, (ident, lastUsed)) -> do
  56             currentTime <- timeCurrent
  57             use <- if currentTime - lastUsed > Elapsed 1800
  58                 then promptYN (not noConfirm) noConfirm $ if isTemporary ident
  59                     then "Reuse old anonymous identity?"
  60                     else "Continue to use identity " ++ showIdentity ansi ident ++ "?"
  61                 else return True
  62             return $ if use
  63                 then (Just ident, Map.insert root (ident, currentTime) ais)
  64                 else (Nothing, Map.delete root ais)