Identity.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 OverloadedStrings #-}
  12
  13 module Identity where
  14
  15 import           Control.Monad             (guard, msum)
  16 import           Control.Monad.IO.Class    (liftIO)
  17 import           Control.Monad.Trans       (lift)
  18 import           Control.Monad.Trans.Maybe
  19 import           Data.Maybe                (mapMaybe)
  20 import           Safe
  21 import           System.Directory          (listDirectory)
  22
  23 import           ANSIColour
  24 import           ClientCert
  25 import           MetaString
  26 import           Mundanities
  27 import           Prompt
  28
  29 data Identity = Identity { identityName :: String, identityCert :: ClientCert }
  30     deriving (Eq,Show)
  31
  32 isTemporary :: Identity -> Bool
  33 isTemporary = null . identityName
  34
  35 normaliseIdName :: String -> Maybe String
  36 normaliseIdName n = headMay (words n)
  37
  38 showIdentity :: MetaString a => Bool -> Identity -> a
  39 showIdentity ansi = showIdentityName ansi . fromString . identityName
  40
  41 showIdentityName :: MetaString a => Bool -> String -> a
  42 showIdentityName ansi name = applyIf ansi (withColourStr Green) $
  43     "[" <> fromString name <> "]"
  44
  45 loadIdentity :: FilePath -> String -> IO (Maybe Identity)
  46 loadIdentity idsPath idName = (Identity idName <$>) <$> loadClientCert idsPath idName
  47
  48 getIdentity :: Bool -> Bool -> FilePath -> String -> IO (Maybe Identity)
  49 getIdentity noConfirm _ _ "" = runMaybeT $ do
  50     (guard =<<) $ lift . promptYN (not noConfirm) True $ "Create and use new temporary anonymous identity?"
  51     Identity "" <$> liftIO (generateSelfSigned "")
  52 getIdentity _ ansi idsPath idName' = runMaybeT $ do
  53     idName <- MaybeT . return $ normaliseIdName idName'
  54     msum [ MaybeT $ loadIdentity idsPath idName
  55         , do
  56             lift $ do
  57                 putStrLn "Creating a new long-term identity."
  58                 putStrLn $ "We will refer to it as " <> showIdentityName ansi idName <> ", but you may also set a \"Common Name\";"
  59                 putStrLn "this is recorded in the identity certificate, and may be interpreted by the server as a username."
  60                 putStrLn "The common name may be left blank. Use ^C to cancel identity generation."
  61             clientCert <- liftIO . generateSelfSigned =<< MaybeT (promptLine "Common Name: ")
  62             liftIO $ mkdirhier idsPath
  63             lift $ saveClientCert idsPath idName clientCert
  64             return $ Identity idName clientCert
  65         ]
  66
  67 getIdentityRequesting :: Bool -> FilePath -> IO (Maybe Identity)
  68 getIdentityRequesting ansi idsPath = runMaybeT $ do
  69     liftIO . putStrLn $ "Enter the name of an existing identity to use (tab completes),\n\t" ++
  70         "or a name for a new identity to create and use,\n\t" ++
  71         "or nothing to create and use a temporary anonymous identity,\n\t" ++
  72         "or use ^C to abort."
  73     let prompt = applyIf ansi (withColourStr Green) "Identity" <> ": "
  74     idName <- MaybeT $ promptLineWithCompletions prompt =<< listIdentities idsPath
  75     MaybeT $ getIdentity True ansi idsPath idName
  76
  77 listIdentities :: FilePath -> IO [String]
  78 listIdentities path = mapMaybe stripCrtExt <$> ignoreIOErr (listDirectory path)
  79     where stripCrtExt s = case splitAt (length s - 4) s of
  80             (s', ".crt") -> Just s'
  81             _            -> Nothing