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