diohsc-0.1.1: 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, TupleSections #-}
{-# LANGUAGE Safe #-}

module Marks where

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

import qualified Data.Map as Map
import qualified Data.ByteString as BS
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 =
    mapSnd 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']