Marks.hs

   1 -- This file is part of Diohsc
   2 -- Copyright (C) 2020 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 OverloadedStrings #-}
  12 {-# LANGUAGE Safe              #-}
  13 {-# LANGUAGE TupleSections     #-}
  14
  15 module Marks where
  16
  17 import           Control.Exception  (handle)
  18 import           Control.Monad      (guard, msum)
  19 import           Data.Bifunctor     (second)
  20 import           Data.Either        (partitionEithers)
  21 import           Data.List          (isPrefixOf)
  22 import           System.Directory
  23 import           System.FilePath
  24
  25 import qualified Data.ByteString    as BS
  26 import qualified Data.Map           as Map
  27 import qualified Data.Text          as TS
  28 import qualified Data.Text.Encoding as TS
  29
  30 import           Mundanities
  31 import           URI
  32 import           Util
  33
  34 data URIWithIdName = URIWithIdName { uriIdUri :: URI, uriIdId :: Maybe String }
  35     deriving (Eq,Show)
  36
  37 showUriWithId :: URIWithIdName -> String
  38 showUriWithId (URIWithIdName uri Nothing) = show uri
  39 showUriWithId (URIWithIdName uri (Just idName)) = show uri ++ "[" ++ idName ++ "]"
  40
  41 readUriWithId :: TS.Text -> Maybe URIWithIdName
  42 readUriWithId s = msum [ do
  43         s' <- TS.stripSuffix "]" s
  44         let (u,i) = TS.breakOn "[" s'
  45             idName = TS.drop 1 i
  46         guard . not $ TS.null idName
  47         uri <- parseUriAsAbsolute $ TS.unpack u
  48         return . URIWithIdName uri . Just $ TS.unpack idName
  49     , (`URIWithIdName` Nothing) <$> parseUriAsAbsolute (TS.unpack s) ]
  50
  51 type Marks = Map.Map String URIWithIdName
  52
  53 emptyMarks :: Marks
  54 emptyMarks = Map.empty
  55
  56 lookupMark :: String -> Marks -> Maybe URIWithIdName
  57 lookupMark s marks = do
  58     (s',uriId) <- Map.lookupGE s marks
  59     guard $ s `isPrefixOf` s'
  60     return uriId
  61
  62 insertMark :: String -> URIWithIdName -> Marks -> Marks
  63 insertMark = Map.insert
  64
  65 loadMarks :: FilePath -> IO ([String], Marks)
  66 loadMarks path =
  67     second Map.fromList . partitionEithers <$> (mapM loadMark =<< ignoreIOErr (listDirectory path))
  68     where
  69     loadMark :: FilePath -> IO (Either String (String, URIWithIdName))
  70     loadMark filename =
  71         let filepath = path </> filename
  72             onIOErr :: IOError -> IO (Either String a)
  73             onIOErr e = return . Left $
  74                 "Error loading mark from " ++ path ++ ": " ++ show e
  75
  76         in handle onIOErr $ maybe (Left $
  77                     "Failed to decode uri in:" ++ show filepath)
  78                 (Right . (filename,)) . readUriWithId . TS.strip . TS.decodeUtf8 <$> BS.readFile filepath
  79
  80 saveMark :: FilePath -> String -> URIWithIdName -> IO ()
  81 saveMark path mark uriId =
  82     let filepath = path </> mark
  83     in isSubPath path filepath >>? mkdirhierto filepath >> writeFile filepath (showUriWithId uriId)
  84
  85 marksWithUri :: URI -> Marks -> [(String,URIWithIdName)]
  86 marksWithUri uri = Map.toList . Map.filter ((==uri) . uriIdUri)
  87
  88 tempMarks :: [String]
  89 tempMarks = (:[]) <$> ['0'..'9']