htalkat-0.1.1: Incoming.hs

-- This file is part of htalkat
-- Copyright (C) 2021 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/.

module Incoming where

import           Control.Monad    (filterM, forM, forM_)
import           Data.List        ((\\))
import           Data.Maybe       (catMaybes)
import           Safe             (maximumMay, readMay)
import           System.Directory
import           System.FileLock  (SharedExclusive (..), withFileLock)
import           System.FilePath  ((</>))

import           Certificate
import           Fingerprint
import           LookupPetname
import           Mundanities
import           Petname
import           Util

type Incoming = Int

addIncoming :: FilePath -> Certificate -> FilePath -> Int -> IO Incoming
addIncoming ddir cert sockPath serial = do
    let idir = incomingDir ddir
    createDirectoryIfMissing True idir
    withFileLock (idir </> ".lock") Exclusive $ \_ -> do
        ns <- incomingNs ddir
        let n = head $ [1..] \\ ns
        let ndir = idir </> show n
        createDirectoryIfMissing False ndir
        writeFile (ndir </> "fp") . showFingerprint $ spkiFingerprint cert
        writeFile (ndir </> "publicName") $ certCN cert
        writeFile (ndir </> "sock") sockPath
        writeFile (ndir </> "serial") $ show serial
        pure n

cleanAllIncoming :: FilePath -> IO ()
cleanAllIncoming ddir = do
    ns <- incomingNs ddir
    forM_ ns $ cleanIncoming ddir Nothing

cleanIncoming :: FilePath -> Maybe Int -> Incoming -> IO ()
cleanIncoming ddir mSerial n =
    let path = incomingPath ddir n
        serialOk | Just s <- mSerial =
                (== Just s) <$> ignoreIOErrAlt (readMay <$> readFile (path </> "serial"))
            | otherwise = pure True
    in doesDirectoryExist path >>? serialOk >>? removeDirectoryRecursive path

incomingDir :: FilePath -> FilePath
incomingDir = (</> "incoming")

incomingNs :: FilePath -> IO [Int]
incomingNs ddir = catMaybes . (readMay <$>) <$>
    listDirectory (incomingDir ddir)

incomingPath :: FilePath -> Incoming -> FilePath
incomingPath ddir n = incomingDir ddir </> show n

lastIncoming :: FilePath -> Maybe Fingerprint -> IO (Maybe Incoming)
lastIncoming ddir mFp = do
    ns <- incomingNs ddir
    maximumMay <$> filterM checkFp ns
    where
    checkFp _ | Nothing <- mFp = pure True
    checkFp n | Just fp <- mFp = (== Just fp) . parseFingerprint <$>
        readFile (incomingPath ddir n </> "fp")

listIncoming :: FilePath -> IO [String]
listIncoming ddir = do
    ns <- incomingNs ddir
    forM ns $ \n -> do
        let idir = incomingPath ddir n
        t <- getModificationTime idir
        petname <- incomingPetname ddir n
        ((show t <> ": " <> showPetname petname) <>) <$> case petname of
            Named _ -> pure ""
            _ -> do
                Just fp <- parseFingerprint <$> readFile (idir </> "fp")
                cn <- readFile (idir </> "publicName")
                pure $ " " <> showFingerprint fp <>
                    if null cn then "" else " \"" <> cn <> "\""


incomingPetname :: FilePath -> Incoming -> IO Petname
incomingPetname ddir n = do
    Just fp <- parseFingerprint <$> readFile (incomingPath ddir n </> "fp")
    lookupOrAddPetname ddir fp