Petname.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 {-# LANGUAGE Safe #-}
  12
  13 module Petname where
  14
  15 import           Control.Monad             (msum)
  16 import           Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT)
  17 import           Data.Char                 (isAlphaNum)
  18 import           Data.List                 (elemIndices)
  19 import           Data.Maybe                (mapMaybe)
  20 import           Safe                      (lastMay, readMay)
  21 import           System.Directory          (createDirectoryIfMissing,
  22                                             listDirectory)
  23 import           System.FileLock           (SharedExclusive (..), withFileLock)
  24 import           System.FilePath           (isValid, takeFileName, (</>))
  25
  26 import           Host
  27 import           Mundanities
  28 import           User
  29
  30 #if !(MIN_VERSION_base(4,11,0))
  31 import           Data.Semigroup
  32 #endif
  33
  34 data Petname = Named String | Unnamed Int
  35     deriving (Eq)
  36
  37 instance Ord Petname where
  38     compare (Named _) (Unnamed _)    = LT
  39     compare (Unnamed _) (Named _)    = GT
  40     compare (Named n) (Named n')
  41         | c <- compare (length n) (length n')
  42         , c /= EQ                    = c
  43     compare (Named n) (Named n')     = compare n n'
  44     compare (Unnamed n) (Unnamed n') = compare n n'
  45
  46 parsePetname :: String -> Maybe Petname
  47 parsePetname ('+':s) | Just n <- readMay s, n > 0 = Just $ Unnamed n
  48 parsePetname s | isValidPetname s = Just $ Named s
  49 parsePetname _ = Nothing
  50
  51 isValidPetname :: String -> Bool
  52 isValidPetname ('.':_) = False
  53 isValidPetname s       = shellQuotable s && isValid s && s == takeFileName s
  54     where shellQuotable = notElem '\''
  55
  56 showPetname :: Petname -> String
  57 showPetname (Named s)   = s
  58 showPetname (Unnamed n) = '+':show n
  59
  60 shellQuotePetname :: Petname -> String
  61 shellQuotePetname = shellQuote . showPetname where
  62     shellQuote s
  63         | all shellSafe s && not (null s) = s
  64         | otherwise = '\'' : s <> "'"
  65     shellSafe c = isAlphaNum c || c `elem` ".,_-+="
  66
  67 namesDir :: FilePath -> FilePath
  68 namesDir = (</> "names")
  69
  70 lookupName :: FilePath -> Petname -> IO (Maybe User)
  71 lookupName ddir name = do
  72     let ndir = namesDir ddir
  73         path = ndir </> showPetname name
  74     createDirectoryIfMissing True ndir
  75     ignoreIOErrAlt . withFileLock (ndir </> ".lock") Shared $ \_ ->
  76         parseUser <$> readFile path
  77
  78 resolveTarget :: FilePath -> String -> IO (Maybe User)
  79 resolveTarget ddir target
  80     | Just user <- parseUser target = pure $ Just user
  81     | otherwise = runMaybeT $ msum
  82         [ do
  83             name <- MaybeT . pure $ parsePetname target
  84             MaybeT $ lookupName ddir name
  85         , do
  86             i <- MaybeT . pure . lastMay $ elemIndices '@' target
  87             let (n, '@':h) = splitAt i target
  88             name <- MaybeT . pure $ parsePetname n
  89             host <- MaybeT . pure $ parseHost h
  90             MaybeT $ ((\u -> u { userHost = Just host }) <$>) <$>
  91                 lookupName ddir name
  92         ]
  93
  94 writeName :: FilePath -> User -> Petname -> IO ()
  95 writeName ddir user name = do
  96     let ndir = namesDir ddir
  97         path = ndir </> showPetname name
  98     createDirectoryIfMissing True ndir
  99     withFileLock (ndir </> ".lock") Exclusive $ \_ ->
 100         writeFile path $ showUser user
 101
 102 loadNames :: FilePath -> IO [Petname]
 103 loadNames ddir = mapMaybe parsePetname <$> listDirectory (namesDir ddir)