ResolveTarget.hs

   1 -- This file is part of Diohsc
   2 -- Copyright (C) 2020-23 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 LambdaCase #-}
  12
  13 module ResolveTarget (resolveTarget) where
  14
  15 import           Data.Char      (isUpper)
  16 import           Data.Hashable  (hash)
  17 import           Data.Maybe
  18 import           Safe
  19 import           Text.Regex     (matchRegex, mkRegexWithOpts)
  20
  21 import qualified Data.Map       as M
  22 import qualified Data.Set       as S
  23 import qualified Data.Text.Lazy as T
  24
  25 import qualified BStack
  26 import           ClientState    (ClientState (..))
  27 import           CommandLine
  28 import           History
  29 import           Marks
  30 import           Queue
  31 import           Target
  32 import           TextGemini
  33 import           URI
  34 import           Util           (maybeToEither)
  35
  36 resolveTarget :: ClientState -> PTarget -> Either String [Target]
  37 resolveTarget (ClientState curr jumpBack cLog visited queues _ marks sessionMarks _ _) =
  38     resolveTarget'
  39     where
  40     resolveTarget' PTargetCurr =
  41         (:[]) . TargetHistory <$> maybeToEither "No current location" curr
  42
  43     resolveTarget' PTargetJumpBack =
  44         (:[]) . TargetHistory <$> maybeToEither "'' mark not set" jumpBack
  45
  46     resolveTarget' (PTargetMark s)
  47         | Just n <- readMay s =
  48             (:[]) . TargetHistory <$> maybeToEither ("Mark not set: " <> s) (M.lookup n sessionMarks)
  49         | otherwise =
  50             (:[]) . targetOfMark <$> maybeToEither ("Unknown mark: " <> s) (lookupMark s marks)
  51             where
  52             targetOfMark (URIWithIdName uri Nothing) = TargetUri uri
  53             targetOfMark (URIWithIdName uri (Just idName)) = TargetIdUri idName uri
  54
  55     resolveTarget' (PTargetLog specs) =
  56         (TargetUri <$>) <$> resolveElemsSpecs "log entry" (matchPatternOn show) loggedUris specs
  57
  58     resolveTarget' (PTargetQueue qname specs) =
  59         (queueTarget <$>) <$> resolveElemsSpecs "queue item"
  60             (matchPatternOn $ show . queueUri) queue specs
  61         where
  62         queue = M.findWithDefault [] qname queues
  63         queueTarget (QueueURI Nothing uri)  = TargetUri uri
  64         queueTarget (QueueURI (Just o) uri) = TargetFrom o uri
  65         queueTarget (QueueHistory item)     = TargetHistory item
  66
  67     resolveTarget' (PTargetRoot base) =
  68         (rootOf <$>) <$> resolveTarget' base
  69         where
  70         rootOf :: Target -> Target
  71         rootOf (TargetHistory item)                  = rootOfItem item
  72         rootOf (TargetFrom (HistoryOrigin item _) _) = rootOfItem item
  73         rootOf t                                     = t
  74         rootOfItem item = TargetHistory . lastDef item $ historyAncestors item
  75
  76     resolveTarget' (PTargetAncestors base specs) =
  77         concat <$> (mapM resolveAncestors =<< resolveTarget' base)
  78         where
  79         resolveAncestors :: Target -> Either String [Target]
  80         resolveAncestors (TargetHistory item) =
  81             resolveAncestors' $ historyAncestors item
  82         resolveAncestors (TargetFrom (HistoryOrigin item _) _) =
  83             resolveAncestors' $ item : historyAncestors item
  84         resolveAncestors _ = Left "No history"
  85         resolveAncestors' hist = (TargetHistory <$>) <$>
  86             resolveElemsSpecs "ancestor" (matchPatternOn $ show . historyUri)
  87                 hist specs
  88
  89     resolveTarget' (PTargetDescendants base specs) =
  90         concat <$> (mapM resolveDescendants =<< resolveTarget' base)
  91         where
  92         resolveDescendants :: Target -> Either String [Target]
  93         resolveDescendants (TargetHistory item) = (TargetHistory <$>) <$>
  94             resolveElemsSpecs "descendant" (matchPatternOn $ show . historyUri)
  95                 (historyDescendants item) specs
  96         resolveDescendants _ = Left "No history"
  97
  98     resolveTarget' (PTargetChild increasing noVisited base specs) =
  99         concat <$> (mapM resolveChild =<< resolveTarget' base)
 100         where
 101         resolveChild (TargetHistory item) =
 102             let itemLinks = historyLinks item
 103                 b = case historyChild item of
 104                     Just (HistoryChild _ (Just b')) -> b'
 105                     _ | increasing                  -> -1
 106                     _                               -> length itemLinks
 107                 slice | increasing = zip [b+1..] $ drop (b+1) itemLinks
 108                     | otherwise = zip (reverse [0..b-1]) . reverse $ take b itemLinks
 109                 linkUnvisited (_,l) = not . isVisited $ linkUri l `relativeTo` historyUri item
 110                 slice' | noVisited = filter linkUnvisited slice
 111                     | otherwise = slice
 112             in resolveLinkSpecs False item slice' specs
 113         resolveChild _ = Left "No known links"
 114
 115     resolveTarget' (PTargetLinks noVisited base specs) =
 116         concat <$> (mapM resolveLinks =<< resolveTarget' base)
 117         where
 118         resolveLinks (TargetHistory item) =
 119             let itemLinks = historyLinks item
 120             in resolveLinkSpecs noVisited item (zip [0..] itemLinks) specs
 121         resolveLinks _ = Left "No known links"
 122
 123     resolveTarget' (PTargetRef base s) =
 124         let makeRel r | base == PTargetCurr = r
 125             makeRel r@('/':_) = '.':r
 126             makeRel r = r
 127         in case parseUriReference . escapeIRI . escapeQueryPart $ makeRel s of
 128             Nothing -> Left $ "Failed to parse relative URI: " <> s
 129             Just ref -> map relTarget <$> resolveTarget' base
 130                 where
 131                 relTarget (TargetHistory item) = TargetFrom (HistoryOrigin item Nothing) $
 132                     ref `relativeTo` historyUri item
 133                 relTarget (TargetFrom o uri) = TargetFrom o $ relativeTo ref uri
 134                 relTarget t = TargetUri . relativeTo ref $ targetUri t
 135
 136     resolveTarget' (PTargetAbs s) = case parseUriAsAbsolute . escapeIRI $ escapeQueryPart s of
 137         Nothing  -> Left $ "Failed to parse URI: " <> s
 138         Just uri -> return [TargetUri uri]
 139
 140     resolveLinkSpecs :: Bool -> HistoryItem -> [(Int,Link)] -> ElemsSpecs -> Either String [Target]
 141     resolveLinkSpecs purgeVisited item slice specs =
 142         let isMatch s (_,l) = matchPattern s (show $ linkUri l) ||
 143                 matchPattern s (T.unpack $ linkDescription l)
 144             linkTarg (n,l) =
 145                 let uri = linkUri l `relativeTo` historyUri item
 146                 in if purgeVisited && isVisited uri then Nothing
 147                     else Just $ TargetFrom (HistoryOrigin item $ Just n) uri
 148         in resolveElemsSpecs "link" isMatch slice specs >>= (\case
 149             []    -> Left "No such link"
 150             targs -> return targs) . mapMaybe linkTarg
 151
 152     matchPattern :: String -> String -> Bool
 153     matchPattern patt =
 154         let regex = mkRegexWithOpts patt True (any isUpper patt)
 155         in isJust . matchRegex regex
 156
 157     matchPatternOn :: (a -> String) -> String -> a -> Bool
 158     matchPatternOn f patt = matchPattern patt . f
 159
 160     isVisited :: URI -> Bool
 161     isVisited uri = S.member (hash . T.pack $ show uri) visited
 162
 163     loggedUris = catMaybes $ (parseAbsoluteUri . escapeIRI . T.unpack <$>) $ BStack.toList cLog