Incoming.hs

   1 -- This file is part of htalkat
   2 -- Copyright (C) 2021 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 module Incoming where
  12
  13 import           Control.Monad    (filterM, forM, forM_)
  14 import           Data.List        ((\\))
  15 import           Data.Maybe       (mapMaybe)
  16 import           Safe             (maximumMay, readMay)
  17 import           System.Directory
  18 import           System.FileLock  (SharedExclusive (..), withFileLock)
  19 import           System.FilePath  ((</>))
  20
  21 import           Certificate
  22 import           Fingerprint
  23 import           LookupPetname
  24 import           Mundanities
  25 import           Petname
  26 import           Util
  27
  28 #if !(MIN_VERSION_base(4,11,0))
  29 import           Data.Semigroup
  30 #endif
  31
  32 type Incoming = Int
  33
  34 addIncoming :: FilePath -> Certificate -> FilePath -> Int -> IO Incoming
  35 addIncoming ddir cert sockPath serial = do
  36     let idir = incomingDir ddir
  37     createDirectoryIfMissing True idir
  38     withFileLock (idir </> ".lock") Exclusive $ \_ -> do
  39         ns <- incomingNs ddir
  40         let n = head $ [1..] \\ ns
  41         let ndir = idir </> show n
  42         createDirectoryIfMissing False ndir
  43         writeFile (ndir </> "fp") . showFingerprint $ spkiFingerprint cert
  44         writeFile (ndir </> "publicName") $ certCN cert
  45         writeFile (ndir </> "sock") sockPath
  46         writeFile (ndir </> "serial") $ show serial
  47         pure n
  48
  49 cleanAllIncoming :: FilePath -> IO ()
  50 cleanAllIncoming ddir = do
  51     ns <- incomingNs ddir
  52     forM_ ns $ cleanIncoming ddir Nothing
  53
  54 cleanIncoming :: FilePath -> Maybe Int -> Incoming -> IO ()
  55 cleanIncoming ddir mSerial n =
  56     let path = incomingPath ddir n
  57         serialOk | Just s <- mSerial =
  58                 (== Just s) <$> ignoreIOErrAlt (readMay <$> readFile (path </> "serial"))
  59             | otherwise = pure True
  60     in doesDirectoryExist path >>? serialOk >>? removeDirectoryRecursive path
  61
  62 incomingDir :: FilePath -> FilePath
  63 incomingDir = (</> "incoming")
  64
  65 incomingNs :: FilePath -> IO [Int]
  66 incomingNs ddir = mapMaybe readMay <$> listDirectory (incomingDir ddir)
  67
  68 incomingPath :: FilePath -> Incoming -> FilePath
  69 incomingPath ddir n = incomingDir ddir </> show n
  70
  71 lastIncoming :: FilePath -> Maybe Fingerprint -> IO (Maybe Incoming)
  72 lastIncoming ddir mFp = do
  73     ns <- incomingNs ddir
  74     maximumMay <$> filterM checkFp ns
  75     where
  76     checkFp _ | Nothing <- mFp = pure True
  77     checkFp n | Just fp <- mFp = (== Just fp) . parseFingerprint <$>
  78         readFile (incomingPath ddir n </> "fp")
  79
  80 listIncoming :: FilePath -> IO [String]
  81 listIncoming ddir = do
  82     ns <- incomingNs ddir
  83     forM ns $ \n -> do
  84         let idir = incomingPath ddir n
  85         t <- getModificationTime idir
  86         petname <- incomingPetname ddir n
  87         ((show t <> ": " <> showPetname petname) <>) <$> case petname of
  88             Named _ -> pure ""
  89             _ -> do
  90                 Just fp <- parseFingerprint <$> readFile (idir </> "fp")
  91                 cn <- readFile (idir </> "publicName")
  92                 pure $ " " <> showFingerprint fp <>
  93                     if null cn then "" else " \"" <> cn <> "\""
  94
  95
  96 incomingPetname :: FilePath -> Incoming -> IO Petname
  97 incomingPetname ddir n = do
  98     Just fp <- parseFingerprint <$> readFile (incomingPath ddir n </> "fp")
  99     lookupOrAddPetname ddir fp