content: {- HLINT ignore -}
  {-# LANGUAGE OverloadedStrings #-}
  {-# LANGUAGE RecordWildCards #-}
  {-# LANGUAGE ScopedTypeVariables #-}
  
  module Hoodle.Publish.PDF where
  
  {-
  import Control.Applicative ((<|>))
  import Control.Exception (SomeException (..), catch)
  import Control.Lens (view, _1, _2, _3, _4)
  import Control.Monad (forM, forM_, unless, void, when, (<=<))
  import Control.Monad.Trans (lift, liftIO)
  import Control.Monad.Trans.Maybe (MaybeT (..))
  import Control.Monad.Trans.State (StateT (..), evalStateT, get, gets, modify, put)
  import Data.Attoparsec.ByteString.Char8
    ( anyChar,
      endOfInput,
      inClass,
      manyTill,
      parseOnly,
      satisfy,
      string,
      try,
    )
  import qualified Data.ByteString.Char8 as B
  import qualified Data.ByteString.Lazy as BSL
  import Data.Either (isLeft)
  import Data.Functor (($>))
  import qualified Data.Hoodle.Simple as S
  import Data.Int (Int64)
  import Data.Maybe (catMaybes)
  import Data.UUID (UUID, fromString)
  import Data.UUID.V4 (nextRandom)
  import Graphics.Hoodle.Render
    ( initRenderContext,
      renderPageStateT,
    )
  import Graphics.Rendering.Cairo
    ( pdfSurfaceSetSize,
      renderWith,
      showPage,
      withPDFSurface,
    )
  import Network.HTTP.Base (urlEncode)
  import Network.URI (unEscapeString)
  import Pdf.Core
    ( Array (..),
      Dict (..),
      Object (..),
      -- PdfWriter,
      Ref (..),
      -- Str (..),
      Stream (..),
      -- deleteObject,
      -- rawStreamContent,
      -- runPdfWriter,
      -- writeObject,
      -- writePdfHeader,
      -- writeXRefTable,
    )
  import Pdf.Document
    ( Pdf,
      catalogPageNode,
      defaultUserPassword,
      deref,
      document,
      documentCatalog,
      -- fromObject,
      -- getRIS,
      -- intValue,
      isEncrypted,
      -- knownFilters,
      -- lookupDict,
      lookupObject,
      -- mapObject,
      pageContents,
      pageNodeNKids,
      pageNodePageByNum,
      -- runPdfWithHandle,
      setUserPassword,
      -- toStream,
    )
  import Pdf.Document.Internal.Types (Page (..))
  import System.Directory
    ( canonicalizePath,
      doesDirectoryExist,
      doesFileExist,
      getModificationTime,
      getTemporaryDirectory,
      removeFile,
    )
  import System.Directory.Tree (DirTree (..))
  import System.FilePath
    ( makeRelative,
      splitExtension,
      splitFileName,
      takeExtension,
      (<.>),
      (</>),
    )
  import System.IO
    ( IOMode (ReadMode),
      hClose,
      openBinaryFile,
    )
  import qualified System.IO.Streams as Streams
  import System.Process (readProcessWithExitCode, system)
  import Text.Hoodle.Parse.Attoparsec (hoodle)
  
  data UrlPath = FileUrl FilePath | HttpUrl String
    deriving (Show, Eq)
  
  data T = N | F | H | HS deriving (Show, Eq)
  
  -- |
  urlParse :: String -> Maybe UrlPath
  urlParse str =
    if length str < 7
      then Just (FileUrl str)
      else
        let p = do
              b <-
                try (string "file://" $> F)
                  <|> try (string "http://" $> H)
                  <|> try (string "https://" $> HS)
                  <|> return N
              remain <- manyTill anyChar ((satisfy (inClass "\r\n") $> ()) <|> endOfInput)
              return (b, remain)
            r = parseOnly p (B.pack str)
         in case r of
              Left _ -> Nothing
              Right (b, f) -> case b of
                N -> Just (FileUrl f)
                F -> Just (FileUrl (unEscapeString f))
                H -> Just (HttpUrl ("http://" ++ f))
                HS -> Just (HttpUrl ("https://" ++ f))
  
  isFile :: DirTree a -> Bool
  isFile (File _ _) = True
  isFile _ = False
  
  takeFile :: DirTree a -> Maybe a
  takeFile x
    | isFile x = (Just . file) x
    | otherwise = Nothing
  
  data Annot = Annot
    { annot_rect :: (Int, Int, Int, Int),
      annot_border :: (Int, Int, Int),
      annot_act :: AnnotActions
    }
  
  data AnnotActions = OpenURI String | OpenApp String
  
  data AppState = AppState
    { stNextFree :: Int,
      stPageRefs :: [Ref],
      stRootNode :: Ref
    }
  
  initialAppState :: AppState
  initialAppState =
    AppState
      { stNextFree = 1,
        stPageRefs = [],
        stRootNode = error "stRootNode"
      }
  
  nextFreeIndex :: Monad m => StateT AppState m Int
  nextFreeIndex = do
    st <- get
    let index = stNextFree st
    put $ st {stNextFree = index + 1}
    return index
  
  putPageRef :: Monad m => Ref -> StateT AppState m ()
  putPageRef ref = modify $ \st -> st {stPageRefs = ref : stPageRefs st}
  
  writeTrailer :: StateT AppState (PdfWriter IO) ()
  writeTrailer = do
    pageRefs <- gets stPageRefs
    rootRef <- gets stRootNode
    lift $
      writeObject rootRef $
        ODict $
          Dict
            [ ("Type", OName "Pages"),
              ("Count", ONumber $ NumInt $ length pageRefs),
              ("Kids", OArray $ Array $ map ORef $ reverse pageRefs)
            ]
    catalogIndex <- nextFreeIndex
    let catalogRef = Ref catalogIndex 0
    lift $ writeObject catalogRef $ ODict $ Dict [("Type", OName "Catalog"), ("Pages", ORef rootRef)]
    n <- gets stNextFree
    lift $ writeXRefTable 0 (Dict [("Size", (ONumber . NumInt) (n - 1)), ("Root", ORef catalogRef)])
  
  writeObjectChildren :: Object () -> Pdf (StateT AppState (PdfWriter IO)) (Object ())
  writeObjectChildren (ORef r) = do
    o <- lookupObject r
    case o of
      OStream s -> do
        ref <- writeStream s
        return $ ORef ref
      _ -> do
        let o' = mapObject (error "impossible") o
        o'' <- writeObjectChildren o'
        index <- (lift . lift) nextFreeIndex
        let ref = Ref index 0
        (lift . lift . lift) $ writeObject ref $ mapObject (error "impossible") o''
        return $ ORef ref
  writeObjectChildren (ODict (Dict vals)) = do
    vals' <- forM vals $ \(key, val) -> do
      val' <- writeObjectChildren val
      return (key, val')
    return $ ODict $ Dict vals'
  writeObjectChildren (OArray (Array vals)) = do
    vals' <- forM vals writeObjectChildren
    return $ OArray $ Array vals'
  writeObjectChildren o = return o
  
  -- |
  writeStream :: Stream Int64 -> Pdf (StateT AppState (PdfWriter IO)) Ref
  writeStream s@(Stream dict _) = do
    len <- lookupDict "Length" dict >>= deref >>= fromObject >>= intValue
    ris <- getRIS
    Stream _ is <- rawStreamContent ris len s
    content <- liftIO $ BSL.fromChunks `fmap` Streams.toList is
    index <- (lift . lift) nextFreeIndex
    let ref = Ref index 0
    dict' <- writeObjectChildren (ODict dict) >>= fromObject
    lift . lift . lift $ writeObject ref $ OStream $ Stream dict' content
    return ref
  
  -- |
  writeAnnot :: Annot -> Pdf (StateT AppState (PdfWriter IO)) Ref
  writeAnnot Annot {..} = do
    annotIndex <- (lift . lift) nextFreeIndex
    actionIndex <- (lift . lift) nextFreeIndex
    let annotRef = Ref annotIndex 0
        actionRef = Ref actionIndex 0
    let annotDict =
          Dict
            [ ("Type", OName "Annot"),
              ("Subtype", OName "Link"),
              ( "Rect",
                OArray $
                  Array
                    [ ONumber (NumInt (view _1 annot_rect)),
                      ONumber (NumInt (view _2 annot_rect)),
                      ONumber (NumInt (view _3 annot_rect)),
                      ONumber (NumInt (view _4 annot_rect))
                    ]
              ),
              ( "Border",
                OArray $
                  Array
                    [ ONumber (NumInt (view _1 annot_border)),
                      ONumber (NumInt (view _2 annot_border)),
                      ONumber (NumInt (view _3 annot_border))
                    ]
              ),
              ("A", ORef actionRef)
            ]
        actionDict = case annot_act of
          OpenURI uri ->
            Dict
              [ ("S", OName "URI"),
                ("URI", OStr (Str (B.pack uri)))
              ]
          OpenApp str ->
            Dict
              [ ("S", OName "Launch"),
                ("F", OStr (Str (B.pack str)))
              ]
    lift . lift . lift $ writeObject annotRef $ ODict annotDict
    lift . lift . lift $ writeObject actionRef $ ODict actionDict
    return annotRef
  
  -- |
  writePdfPageWithAnnot ::
    S.Dimension ->
    Maybe [Annot] ->
    Page ->
    Pdf (StateT AppState (PdfWriter IO)) ()
  writePdfPageWithAnnot (S.Dim w h) mannots pg@(Page _ pageDict) = do
    parentRef <- lift . lift $ gets stRootNode
    pageIndex <- (lift . lift) nextFreeIndex
    let pageRef = Ref pageIndex 0
    lift . lift $ putPageRef pageRef
    contentRefs <- pageContents pg
    contentRefs' <- forM contentRefs $ \r -> do
      s <- lookupObject r >>= toStream
      writeStream s
    resources <- lookupDict "Resources" pageDict >>= deref >>= writeObjectChildren
    case mannots of
      Nothing ->
        lift . lift . lift $
          writeObject pageRef $
            ODict $
              Dict
                [ ("Type", OName "Page"),
                  ("Contents", OArray $ Array $ map ORef contentRefs'),
                  ("MediaBox", OArray $ Array $ map (ONumber . NumInt) [0, 0, floor w, floor h]),
                  ("Resources", resources),
                  ("Parent", ORef parentRef)
                ]
      Just anns -> do
        annrefs <- mapM writeAnnot anns
        lift . lift . lift $
          writeObject pageRef $
            ODict $
              Dict
                [ ("Type", OName "Page"),
                  ("Contents", OArray $ Array $ map ORef contentRefs'),
                  ("MediaBox", OArray $ Array $ map (ONumber . NumInt) [0, 0, floor w, floor h]),
                  ("Resources", resources),
                  ("Parent", ORef parentRef),
                  ("Annots", (OArray . Array . map ORef) annrefs)
                ]
  
  -- |
  makeAnnot ::
    S.Dimension ->
    String ->
    (FilePath, FilePath) ->
    S.Link ->
    IO (Maybe Annot)
  makeAnnot (S.Dim _pw ph) urlbase (rootpath, _currpath) lnk = do
    let (x, y) = S.link_pos lnk
        S.Dim w h = S.link_dim lnk
        -- pwi = floor pw
        phi = floor ph
        xi = floor x
        yi = floor y
        wi = floor w
        hi = floor h
        linkpath = (B.unpack . S.link_location) lnk
    case urlParse linkpath of
      Nothing -> return Nothing
      Just urlpath -> do
        case urlpath of
          HttpUrl url ->
            return
              ( Just
                  Annot
                    { annot_rect = (xi, phi - yi, xi + wi, phi - (yi + hi)),
                      annot_border = (16, 16, 1),
                      annot_act = OpenURI url
                    }
              )
          FileUrl _path -> do
            b <- doesFileExist linkpath
            if b
              then do
                fp <- canonicalizePath linkpath
                let (dir, fn) = splitFileName fp
                    rdir = makeRelative rootpath dir
                    (fb, _ext) = splitExtension fn
                return
                  ( Just
                      Annot
                        { annot_rect = (xi, phi - yi, xi + wi, phi - (yi + hi)),
                          annot_border = (16, 16, 1),
                          annot_act = OpenURI (urlbase </> rdir </> urlEncode fb <.> "pdf")
                        }
                  )
              else return Nothing
  
  -- |
  writePdfFile ::
    -- | hoodle file path
    FilePath ->
    S.Dimension ->
    -- | (url base, special url base (for executing an app))
    (String, String) ->
    -- | (root path, curr path)
    (FilePath, FilePath) ->
    -- | pdf file
    FilePath ->
    [(Int, [S.Link])] ->
    Maybe UUID ->
    StateT AppState (PdfWriter IO) ()
  writePdfFile _hdlfp dim (urlbase, specialurlbase) (rootpath, currpath) path nlnks muuid = do
    handle <- liftIO $ openBinaryFile path ReadMode
    res <- runPdfWithHandle handle knownFilters $ do
      encrypted <- isEncrypted
      when encrypted $ void $ setUserPassword defaultUserPassword
      root <- document >>= documentCatalog >>= catalogPageNode
      count <- pageNodeNKids root
      forM_ [0 .. count - 1] $ \i -> do
        page <- pageNodePageByNum root i
        mannots <- runMaybeT $ do
          lnks <- MaybeT . return $ lookup (i + 1) nlnks
          fmap catMaybes . mapM (liftIO . makeAnnot dim urlbase (rootpath, currpath)) $ lnks
        -- hdlfp' <- liftIO $ canonicalizePath hdlfp
        let special =
              if i == 0
                then
                  let S.Dim _w h = dim
                   in [ Annot
                          { annot_rect = (0, floor h, 100, floor h - 100),
                            annot_border = (16, 16, 1),
                            annot_act = specialURIFunction specialurlbase muuid
                          }
                      ]
                else []
        let mannots' = case mannots of
              Nothing -> Just special
              Just anns -> Just (anns ++ special)
        writePdfPageWithAnnot dim mannots' page
    when (isLeft res) $ error $ show res
    liftIO $ hClose handle
  
  specialURIFunction ::
    FilePath ->
    Maybe UUID ->
    AnnotActions
  specialURIFunction baseurl muuid =
    case muuid of
      Nothing -> error "muuid = Nothing?" -- OpenURI baseurl
      Just uuid -> OpenURI (baseurl </> urlEncode (show uuid))
  
  getLinks :: S.Page -> [S.Link]
  getLinks pg = do
    l <- view S.layers pg
    S.ItemLink lnk <- view S.items l
    return lnk
  
  isHdl :: FilePath -> Bool
  isHdl = (== ".hdl") <$> takeExtension
  
  isPdf :: FilePath -> Bool
  isPdf = (== ".pdf") <$> takeExtension
  
  -- | interleaving a monadic action between each pair of subsequent actions
  sequence1_ :: (Monad m) => m () -> [m ()] -> m ()
  sequence1_ _ [] = return ()
  sequence1_ _ [a] = a
  sequence1_ i (a : as) = a >> i >> sequence1_ i as
  
  -- | render a hoodle file to PDF simply
  renderHoodleToPDF :: S.Hoodle -> FilePath -> IO ()
  renderHoodleToPDF hdl ofp = do
    let p = head (view S.pages hdl)
    let S.Dim width height = view S.dimension p
    tdir <- getTemporaryDirectory
    uuid <- nextRandom
    let tempfile = tdir </> show uuid <.> "pdf"
    ctxt <- initRenderContext hdl
    let setsize sfc pg =
          let S.Dim w h = view S.dimension pg
           in pdfSurfaceSetSize sfc w h >> return pg
    _ <- withPDFSurface tempfile width height $ \s ->
      renderWith s . flip runStateT ctxt $
        sequence1_ (lift showPage) . map (renderPageStateT <=< setsize s) . view S.pages $
          hdl
    void $ readProcessWithExitCode "pdftk" [tempfile, "cat", "output", ofp] ""
  
  isUpdated :: (FilePath, FilePath) -> IO Bool
  isUpdated (ofp, nfp) = do
    b <- doesFileExist nfp
    if not b
      then return True
      else do
        otime <- getModificationTime ofp
        ntime <- getModificationTime nfp
        return (otime > ntime)
  
  -- | create pdf file with appropriate links
  createPdf ::
    (String, String) ->
    FilePath ->
    (FilePath, FilePath) ->
    IO ()
  createPdf (urlbase, specialurlbase) rootpath (fn, ofn) = catch action (\(e :: SomeException) -> print e)
    where
      action = do
        putStrLn fn
        let (odir, _) = splitFileName ofn
        b <- doesDirectoryExist odir
        unless b $ void $ system ("mkdir -p " ++ odir)
        let (currpath, _) = splitFileName fn
        Streams.withFileAsOutput ofn $ \ostr -> do
          bstr <- B.readFile fn
          case parseOnly hoodle bstr of
            Left str -> error str
            Right hdl -> do
              let npgs = zip [1 ..] (view S.pages hdl)
                  npglnks = map ((,) <$> fst <*> getLinks . snd) npgs
                  dim = (view S.dimension . snd . head) npgs
                  muuid = (fromString . B.unpack . view S.hoodleID) hdl
              tempfile <- (</>) <$> getTemporaryDirectory <*> fmap show nextRandom
              renderHoodleToPDF hdl tempfile
              --
              runPdfWriter ostr $ do
                writePdfHeader
                deleteObject (Ref 0 65535) 0
                flip evalStateT initialAppState $ do
                  index <- nextFreeIndex
                  modify $ \st -> st {stRootNode = Ref index 0}
                  writePdfFile fn dim (urlbase, specialurlbase) (rootpath, currpath) tempfile npglnks muuid
                  writeTrailer
              removeFile tempfile
  -}
  