LookupPetname.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 {-# LANGUAGE TupleSections #-}
  13
  14 module LookupPetname (lookupPetname, lookupOrAddPetname) where
  15
  16 import           Data.List        (sortBy, (\\))
  17 import           Data.Maybe       (catMaybes)
  18 import           Data.Ord         (Down (..))
  19 import           Data.Traversable (forM)
  20 import           System.FileLock  (SharedExclusive (..), withFileLock)
  21 import           System.FilePath  ((</>))
  22
  23 import qualified Data.Map.Strict  as MS
  24
  25 import           Fingerprint
  26 import           Petname
  27 import           User
  28
  29 newtype NameMap = NameMap (MS.Map Fingerprint Petname)
  30
  31 loadNameMap :: FilePath -> IO NameMap
  32 loadNameMap ddir = do
  33     names <- loadNames ddir
  34     NameMap . MS.fromList
  35         . (onFst userFP <$>)
  36         . sortBy pref
  37         . catMaybes
  38         <$> forM names (\name ->
  39             ((,name) <$>) <$> lookupName ddir name)
  40     where
  41     -- |prefer named to unnamed, then without host to with host, then shortest
  42     pref (User _ Nothing,_) (User _ (Just _),_) = GT
  43     pref (User _ (Just _),_) (User _ Nothing,_) = LT
  44     pref (_,n) (_,n')                           = compare (Down n) (Down n')
  45     onFst f (a,b) = (f a,b)
  46
  47 nameMapLookup :: Fingerprint -> NameMap -> Maybe Petname
  48 nameMapLookup fp (NameMap nm) = MS.lookup fp nm
  49
  50 nameMapNextUnnamed :: NameMap -> Petname
  51 nameMapNextUnnamed (NameMap nm) = head $ (Unnamed <$> [1..]) \\ MS.elems nm
  52
  53 lookupPetname :: FilePath -> Fingerprint -> IO (Maybe Petname)
  54 lookupPetname ddir fp = do
  55     (nameMapLookup fp <$>) . withFileLock (namesDir ddir </> ".lock") Shared $ \_ ->
  56         loadNameMap ddir
  57
  58 lookupOrAddPetname :: FilePath -> Fingerprint -> IO Petname
  59 lookupOrAddPetname ddir fp = do
  60     nm <- withFileLock (namesDir ddir </> ".lock") Shared $ \_ ->
  61         loadNameMap ddir
  62     case nameMapLookup fp nm of
  63         Nothing -> do
  64             let next = nameMapNextUnnamed nm
  65             writeName ddir (User fp Nothing) next
  66             pure next
  67         Just name ->
  68             pure name