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