diohsc-0.1.3: Marks.hs

-- This file is part of Diohsc
-- Copyright (C) 2020 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 OverloadedStrings #-}
{-# LANGUAGE Safe              #-}
{-# LANGUAGE TupleSections     #-}

module Marks where

import           Control.Exception  (handle)
import           Control.Monad      (guard, msum)
import           Data.Bifunctor     (second)
import           Data.Either        (partitionEithers)
import           Data.List          (isPrefixOf)
import           System.Directory
import           System.FilePath

import qualified Data.ByteString    as BS
import qualified Data.Map           as Map
import qualified Data.Text          as TS
import qualified Data.Text.Encoding as TS

import           Mundanities
import           URI
import           Util

data URIWithIdName = URIWithIdName { uriIdUri :: URI, uriIdId :: Maybe String }
    deriving (Eq,Show)

showUriWithId :: URIWithIdName -> String
showUriWithId (URIWithIdName uri Nothing) = show uri
showUriWithId (URIWithIdName uri (Just idName)) = show uri ++ "[" ++ idName ++ "]"

readUriWithId :: TS.Text -> Maybe URIWithIdName
readUriWithId s = msum [ do
        s' <- TS.stripSuffix "]" s
        let (u,i) = TS.breakOn "[" s'
            idName = TS.drop 1 i
        guard . not $ TS.null idName
        uri <- parseUriAsAbsolute $ TS.unpack u
        return . URIWithIdName uri . Just $ TS.unpack idName
    , (`URIWithIdName` Nothing) <$> parseUriAsAbsolute (TS.unpack s) ]

type Marks = Map.Map String URIWithIdName

emptyMarks :: Marks
emptyMarks = Map.empty

lookupMark :: String -> Marks -> Maybe URIWithIdName
lookupMark s marks = do
    (s',uriId) <- Map.lookupGE s marks
    guard $ s `isPrefixOf` s'
    return uriId

insertMark :: String -> URIWithIdName -> Marks -> Marks
insertMark = Map.insert

loadMarks :: FilePath -> IO ([String], Marks)
loadMarks path =
    second Map.fromList . partitionEithers <$> (mapM loadMark =<< ignoreIOErr (listDirectory path))
    where
    loadMark :: FilePath -> IO (Either String (String, URIWithIdName))
    loadMark filename =
        let filepath = path </> filename
            onIOErr :: IOError -> IO (Either String a)
            onIOErr e = return . Left $
                "Error loading mark from " ++ path ++ ": " ++ show e

        in handle onIOErr $ maybe (Left $
                    "Failed to decode uri in:" ++ show filepath)
                (Right . (filename,)) . readUriWithId . TS.strip . TS.decodeUtf8 <$> BS.readFile filepath

saveMark :: FilePath -> String -> URIWithIdName -> IO ()
saveMark path mark uriId =
    let filepath = path </> mark
    in isSubPath path filepath >>? mkdirhierto filepath >> writeFile filepath (showUriWithId uriId)

marksWithUri :: URI -> Marks -> [(String,URIWithIdName)]
marksWithUri uri = Map.toList . Map.filter ((==uri) . uriIdUri)

tempMarks :: [String]
tempMarks = (:[]) <$> ['0'..'9']