htalkat-0.1.1: LookupPetname.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          #-}
{-# LANGUAGE TupleSections #-}

module LookupPetname (lookupPetname, lookupOrAddPetname) where

import           Data.List        (sortBy, (\\))
import           Data.Maybe       (catMaybes)
import           Data.Ord         (Down (..))
import           Data.Traversable (forM)
import           System.FileLock  (SharedExclusive (..), withFileLock)
import           System.FilePath  ((</>))

import qualified Data.Map.Strict  as MS

import           Fingerprint
import           Petname
import           User

newtype NameMap = NameMap (MS.Map Fingerprint Petname)

loadNameMap :: FilePath -> IO NameMap
loadNameMap ddir = do
    names <- loadNames ddir
    NameMap . MS.fromList
        . (onFst userFP <$>)
        . sortBy pref
        . catMaybes
        <$> forM names (\name ->
            ((,name) <$>) <$> lookupName ddir name)
    where
    -- |prefer named to unnamed, then without host to with host, then shortest
    pref (User _ Nothing,_) (User _ (Just _),_) = GT
    pref (User _ (Just _),_) (User _ Nothing,_) = LT
    pref (_,n) (_,n')                           = compare (Down n) (Down n')
    onFst f (a,b) = (f a,b)

nameMapLookup :: Fingerprint -> NameMap -> Maybe Petname
nameMapLookup fp (NameMap nm) = MS.lookup fp nm

nameMapNextUnnamed :: NameMap -> Petname
nameMapNextUnnamed (NameMap nm) = head $ (Unnamed <$> [1..]) \\ MS.elems nm

lookupPetname :: FilePath -> Fingerprint -> IO (Maybe Petname)
lookupPetname ddir fp = do
    (nameMapLookup fp <$>) . withFileLock (namesDir ddir </> ".lock") Shared $ \_ ->
        loadNameMap ddir

lookupOrAddPetname :: FilePath -> Fingerprint -> IO Petname
lookupOrAddPetname ddir fp = do
    nm <- withFileLock (namesDir ddir </> ".lock") Shared $ \_ ->
        loadNameMap ddir
    case nameMapLookup fp nm of
        Nothing -> do
            let next = nameMapNextUnnamed nm
            writeName ddir (User fp Nothing) next
            pure next
        Just name ->
            pure name