diohsc-0.1.14.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 #-}
{-# LANGUAGE TupleSections     #-}

module Marks where

import           Control.Monad      (guard, msum)
import           Data.Char          (isAlphaNum)
import           Data.List          (isPrefixOf)
import           System.Directory
import           System.FilePath
import           System.IO.Unsafe   (unsafeInterleaveIO)

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 . escapeIRI $ TS.unpack u
        return . URIWithIdName uri . Just $ TS.unpack idName
    , (`URIWithIdName` Nothing) <$> (parseUriAsAbsolute . escapeIRI $ TS.unpack s) ]

type Marks = Map.Map String (Maybe URIWithIdName)

emptyMarks :: Marks
emptyMarks = Map.empty

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

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

loadMarks :: FilePath -> IO Marks
loadMarks path =
    (Map.fromList <$>) $ mapM lazyKeyVal =<< ignoreIOErr (listDirectory path)
    where
    lazyKeyVal f = (f,) <$> unsafeInterleaveIO (loadMark f)
    loadMark :: FilePath -> IO (Maybe URIWithIdName)
    loadMark filename =
        let filepath = path </> filename
        in ignoreIOErrAlt $ readUriWithId . TS.strip . TS.decodeUtf8 <$> BS.readFile filepath

markNameValid :: String -> Bool
markNameValid = all isAlphaNum

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

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

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