diohsc-0.1.14: ResolveTarget.hs

-- This file is part of Diohsc
-- Copyright (C) 2020-23 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 LambdaCase #-}

module ResolveTarget (resolveTarget) where

import           Data.Char      (isUpper)
import           Data.Hash      (hash)
import           Data.Maybe
import           Safe
import           Text.Regex     (matchRegex, mkRegexWithOpts)

import qualified Data.Map       as M
import qualified Data.Set       as S
import qualified Data.Text.Lazy as T

import qualified BStack
import           ClientState    (ClientState (..))
import           CommandLine
import           History
import           Marks
import           Queue
import           Target
import           TextGemini
import           URI
import           Util           (maybeToEither)

resolveTarget :: ClientState -> PTarget -> Either String [Target]
resolveTarget (ClientState curr jumpBack cLog visited queues _ marks sessionMarks _ _) =
    resolveTarget'
    where
    resolveTarget' PTargetCurr =
        (:[]) . TargetHistory <$> maybeToEither "No current location" curr

    resolveTarget' PTargetJumpBack =
        (:[]) . TargetHistory <$> maybeToEither "'' mark not set" jumpBack

    resolveTarget' (PTargetMark s)
        | Just n <- readMay s =
            (:[]) . TargetHistory <$> maybeToEither ("Mark not set: " <> s) (M.lookup n sessionMarks)
        | otherwise =
            (:[]) . targetOfMark <$> maybeToEither ("Unknown mark: " <> s) (lookupMark s marks)
            where
            targetOfMark (URIWithIdName uri Nothing) = TargetUri uri
            targetOfMark (URIWithIdName uri (Just idName)) = TargetIdUri idName uri

    resolveTarget' (PTargetLog specs) =
        (TargetUri <$>) <$> resolveElemsSpecs "log entry" (matchPatternOn show) loggedUris specs

    resolveTarget' (PTargetQueue qname specs) =
        (queueTarget <$>) <$> resolveElemsSpecs "queue item"
            (matchPatternOn $ show . queueUri) queue specs
        where
        queue = M.findWithDefault [] qname queues
        queueTarget (QueueURI Nothing uri)  = TargetUri uri
        queueTarget (QueueURI (Just o) uri) = TargetFrom o uri
        queueTarget (QueueHistory item)     = TargetHistory item

    resolveTarget' (PTargetRoot base) =
        (rootOf <$>) <$> resolveTarget' base
        where
        rootOf :: Target -> Target
        rootOf (TargetHistory item)                  = rootOfItem item
        rootOf (TargetFrom (HistoryOrigin item _) _) = rootOfItem item
        rootOf t                                     = t
        rootOfItem item = TargetHistory . lastDef item $ historyAncestors item

    resolveTarget' (PTargetAncestors base specs) =
        concat <$> (mapM resolveAncestors =<< resolveTarget' base)
        where
        resolveAncestors :: Target -> Either String [Target]
        resolveAncestors (TargetHistory item) =
            resolveAncestors' $ historyAncestors item
        resolveAncestors (TargetFrom (HistoryOrigin item _) _) =
            resolveAncestors' $ item : historyAncestors item
        resolveAncestors _ = Left "No history"
        resolveAncestors' hist = (TargetHistory <$>) <$>
            resolveElemsSpecs "ancestor" (matchPatternOn $ show . historyUri)
                hist specs

    resolveTarget' (PTargetDescendants base specs) =
        concat <$> (mapM resolveDescendants =<< resolveTarget' base)
        where
        resolveDescendants :: Target -> Either String [Target]
        resolveDescendants (TargetHistory item) = (TargetHistory <$>) <$>
            resolveElemsSpecs "descendant" (matchPatternOn $ show . historyUri)
                (historyDescendants item) specs
        resolveDescendants _ = Left "No history"

    resolveTarget' (PTargetChild increasing noVisited base specs) =
        concat <$> (mapM resolveChild =<< resolveTarget' base)
        where
        resolveChild (TargetHistory item) =
            let itemLinks = historyLinks item
                b = case historyChild item of
                    Just (HistoryChild _ (Just b')) -> b'
                    _ | increasing                  -> -1
                    _                               -> length itemLinks
                slice | increasing = zip [b+1..] $ drop (b+1) itemLinks
                    | otherwise = zip (reverse [0..b-1]) . reverse $ take b itemLinks
                linkUnvisited (_,l) = not . isVisited $ linkUri l `relativeTo` historyUri item
                slice' | noVisited = filter linkUnvisited slice
                    | otherwise = slice
            in resolveLinkSpecs False item slice' specs
        resolveChild _ = Left "No known links"

    resolveTarget' (PTargetLinks noVisited base specs) =
        concat <$> (mapM resolveLinks =<< resolveTarget' base)
        where
        resolveLinks (TargetHistory item) =
            let itemLinks = historyLinks item
            in resolveLinkSpecs noVisited item (zip [0..] itemLinks) specs
        resolveLinks _ = Left "No known links"

    resolveTarget' (PTargetRef base s) =
        let makeRel r | base == PTargetCurr = r
            makeRel r@('/':_) = '.':r
            makeRel r = r
        in case parseUriReference . escapeIRI . escapeQueryPart $ makeRel s of
            Nothing -> Left $ "Failed to parse relative URI: " <> s
            Just ref -> map relTarget <$> resolveTarget' base
                where
                relTarget (TargetHistory item) = TargetFrom (HistoryOrigin item Nothing) $
                    ref `relativeTo` historyUri item
                relTarget (TargetFrom o uri) = TargetFrom o $ relativeTo ref uri
                relTarget t = TargetUri . relativeTo ref $ targetUri t

    resolveTarget' (PTargetAbs s) = case parseUriAsAbsolute . escapeIRI $ escapeQueryPart s of
        Nothing  -> Left $ "Failed to parse URI: " <> s
        Just uri -> return [TargetUri uri]

    resolveLinkSpecs :: Bool -> HistoryItem -> [(Int,Link)] -> ElemsSpecs -> Either String [Target]
    resolveLinkSpecs purgeVisited item slice specs =
        let isMatch s (_,l) = matchPattern s (show $ linkUri l) ||
                matchPattern s (T.unpack $ linkDescription l)
            linkTarg (n,l) =
                let uri = linkUri l `relativeTo` historyUri item
                in if purgeVisited && isVisited uri then Nothing
                    else Just $ TargetFrom (HistoryOrigin item $ Just n) uri
        in resolveElemsSpecs "link" isMatch slice specs >>= (\case
            []    -> Left "No such link"
            targs -> return targs) . mapMaybe linkTarg

    matchPattern :: String -> String -> Bool
    matchPattern patt =
        let regex = mkRegexWithOpts patt True (any isUpper patt)
        in isJust . matchRegex regex

    matchPatternOn :: (a -> String) -> String -> a -> Bool
    matchPatternOn f patt = matchPattern patt . f

    isVisited :: URI -> Bool
    isVisited uri = S.member (hash $ show uri) visited

    loggedUris = catMaybes $ (parseAbsoluteUri . escapeIRI . T.unpack <$>) $ BStack.toList cLog