htalkat-0.1.1: Petname.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/.

{-# LANGUAGE Safe #-}

module Petname where

import           Control.Monad             (msum)
import           Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT)
import           Data.Char                 (isAlphaNum)
import           Data.List                 (elemIndices)
import           Data.Maybe                (catMaybes)
import           Safe                      (lastMay, readMay)
import           System.Directory          (createDirectoryIfMissing,
                                            listDirectory)
import           System.FileLock           (SharedExclusive (..), withFileLock)
import           System.FilePath           (isValid, takeFileName, (</>))

import           Host
import           Mundanities
import           User

data Petname = Named String | Unnamed Int
    deriving (Eq)

instance Ord Petname where
    compare (Named _) (Unnamed _)    = LT
    compare (Unnamed _) (Named _)    = GT
    compare (Named n) (Named n')
        | c <- compare (length n) (length n')
        , c /= EQ                    = c
    compare (Named n) (Named n')     = compare n n'
    compare (Unnamed n) (Unnamed n') = compare n n'

parsePetname :: String -> Maybe Petname
parsePetname ('+':s) | Just n <- readMay s, n > 0 = Just $ Unnamed n
parsePetname s | isValidPetname s = Just $ Named s
parsePetname _ = Nothing

isValidPetname :: String -> Bool
isValidPetname ('.':_) = False
isValidPetname s       = shellQuotable s && isValid s && s == takeFileName s
    where shellQuotable = notElem '\''

showPetname :: Petname -> String
showPetname (Named s)   = s
showPetname (Unnamed n) = '+':show n

shellQuotePetname :: Petname -> String
shellQuotePetname = shellQuote . showPetname where
    shellQuote s
        | all shellSafe s && not (null s) = s
        | otherwise = '\'' : s <> "'"
    shellSafe c = isAlphaNum c || c `elem` ".,_-+="

namesDir :: FilePath -> FilePath
namesDir = (</> "names")

lookupName :: FilePath -> Petname -> IO (Maybe User)
lookupName ddir name = do
    let ndir = namesDir ddir
        path = ndir </> showPetname name
    createDirectoryIfMissing True ndir
    ignoreIOErrAlt . withFileLock (ndir </> ".lock") Shared $ \_ ->
        parseUser <$> readFile path

resolveTarget :: FilePath -> String -> IO (Maybe User)
resolveTarget ddir target
    | Just user <- parseUser target = pure $ Just user
    | otherwise = runMaybeT $ msum
        [ do
            name <- MaybeT . pure $ parsePetname target
            MaybeT $ lookupName ddir name
        , do
            i <- MaybeT . pure . lastMay $ elemIndices '@' target
            let (n, '@':h) = splitAt i target
            name <- MaybeT . pure $ parsePetname n
            host <- MaybeT . pure $ parseHost h
            MaybeT $ ((\u -> u { userHost = Just host }) <$>) <$>
                lookupName ddir name
        ]

writeName :: FilePath -> User -> Petname -> IO ()
writeName ddir user name = do
    let ndir = namesDir ddir
        path = ndir </> showPetname name
    createDirectoryIfMissing True ndir
    withFileLock (ndir </> ".lock") Exclusive $ \_ ->
        writeFile path $ showUser user

loadNames :: FilePath -> IO [Petname]
loadNames ddir = catMaybes . (parsePetname <$>) <$>
    listDirectory (namesDir ddir)