Create a hyperlink in pdf file using pdf-toolbox

createlink.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}

-- | Hello World in PDF :)
--
-- Right now there are no high level tools for PDF generating.
-- This example is very low level. Nothing more then proof
-- of concept.

module Main
(
  main
)
where

import Control.Lens 
import Control.Monad
import Control.Monad.Trans
import Control.Monad.Trans.State 
import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Lazy as BSL
import Data.Int
import System.IO
import qualified System.IO.Streams as Streams
import Pdf.Toolbox.Core
import Pdf.Toolbox.Document
import Pdf.Toolbox.Document.Internal.Types 

data Annot = Annot { annot_rect :: (Int, Int, Int, Int) 
                   , annot_border :: (Int ,Int, Int) 
                   , annot_url :: 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)]

  count <- gets stNextFree
  lift $ writeXRefTable 0 (Dict [("Size", ONumber $ NumInt $ count - 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 `liftM` 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


writePdfPageWithAnnot :: Annot -> Page -> Pdf (StateT AppState (PdfWriter IO)) ()
writePdfPageWithAnnot Annot{..} page@(Page _ pageDict) = do
  parentRef <- lift.lift $ gets stRootNode
  pageIndex <- (lift.lift) nextFreeIndex
  annotIndex <- (lift.lift) nextFreeIndex
  actionIndex <- (lift.lift) nextFreeIndex
  let pageRef = Ref pageIndex 0
      annotRef = Ref annotIndex 0 
      actionRef = Ref actionIndex 0 
  lift.lift $ putPageRef pageRef
  contentRefs <- pageContents page
  contentRefs' <- forM contentRefs $ \r -> do
    s <- lookupObject r >>= toStream
    writeStream s
  resources <- lookupDict "Resources" pageDict >>= deref >>= writeObjectChildren
  
  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 = Dict [ ("S", OName "URI" ) 
                        , ("URI", OStr (Str (B.pack annot_url)))
                        ] 

  lift.lift.lift $ writeObject annotRef $ ODict annotDict 
  lift.lift.lift $ writeObject actionRef $ ODict actionDict 
  lift.lift.lift $ writeObject pageRef $ ODict $ Dict [ ("Type", OName "Page")
                                                      , ("Contents", OArray $ Array $ map ORef contentRefs')
                                                      , ("Resources", resources)
                                                      , ("Parent", ORef parentRef)
                                                      , ("Annots", OArray $ Array [ ORef annotRef ]) 
                                                      ]


writePdfFile :: FilePath -> StateT AppState (PdfWriter IO) ()
writePdfFile path = do
  let annot = Annot { annot_rect = (100, 100, 200, 200) 
                    , annot_border = (16,16,1) 
                    , annot_url = "http://ianwookim.org/hoodle" }
  handle <- liftIO $ openBinaryFile path ReadMode
  res <- runPdfWithHandle handle knownFilters $ do
    encrypted <- isEncrypted
    when encrypted $ setUserPassword defaultUserPassord
    root <- document >>= documentCatalog >>= catalogPageNode
    count <- pageNodeNKids root
    forM_ [0..count-1] $ \i -> do
      page <- pageNodePageByNum root i
      writePdfPageWithAnnot annot page
  when (isLeft res) $ error $ show res
  liftIO $ hClose handle


main :: IO ()
main = do
  runPdfWriter Streams.stdout $ do 
    writePdfHeader
    deleteObject (Ref 0 65535) 0 
    flip evalStateT initialAppState $ do 
     index <- nextFreeIndex 
     modify $ \st -> st { stRootNode = Ref index 0} 
     writePdfFile "test.pdf" 
     writeTrailer