History.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 OverloadedStrings #-}
  12
  13 module History where
  14 import           Data.List                (find)
  15 import           Time.Types               (ElapsedP)
  16
  17 import qualified Codec.MIME.Type          as MIME
  18 import qualified Data.Text.Encoding.Error as T
  19 import qualified Data.Text.Lazy.Encoding  as T
  20
  21 import           GeminiProtocol
  22 import           Request
  23 import           TextGemini
  24 import           URI
  25
  26 data HistoryChild = HistoryChild
  27     { childItem :: HistoryItem
  28     , childLink :: Maybe Int
  29     }
  30
  31 data HistoryOrigin = HistoryOrigin
  32     { originItem :: HistoryItem
  33     , originLink :: Maybe Int
  34     }
  35
  36 data HistoryItem = HistoryItem
  37     { historyRequest            :: Request
  38     , historyRequestTime        :: ElapsedP
  39     , historyMimedData          :: MimedData
  40     , historyGeminatedMimedData :: MimedData -- ^generated with lazy IO
  41     , historyParent             :: Maybe HistoryItem
  42     , historyChild              :: Maybe HistoryChild
  43     }
  44
  45 historyUri :: HistoryItem -> URI
  46 historyUri = requestUri . historyRequest
  47
  48 historyAncestors :: HistoryItem -> [HistoryItem]
  49 historyAncestors i = case historyParent i of
  50         Nothing -> []
  51         Just i' -> i' : historyAncestors i'
  52
  53 historyDescendants :: HistoryItem -> [HistoryItem]
  54 historyDescendants i = case historyChild i of
  55         Nothing                  -> []
  56         Just (HistoryChild i' _) -> i' : historyDescendants i'
  57
  58 pathItemByUri :: HistoryItem -> URI -> Maybe HistoryItem
  59 pathItemByUri i uri = find ((uri ==) . historyUri) $
  60     historyAncestors i ++ [i] ++ historyDescendants i
  61
  62 historyLinks :: HistoryItem -> [Link]
  63 historyLinks item = case historyGeminatedMimedData item of
  64     MimedData (MIME.Type (MIME.Text "gemini") _) body ->
  65         extractLinks . parseGemini $ T.decodeUtf8With T.lenientDecode body
  66     _ -> []