imagepaste-0.2.0.0: src/Engine.hs

{-# LANGUAGE TypeSynonymInstances, GeneralizedNewtypeDeriving #-}

module Engine (
  runPasteHandler,

  fetch,
  engineNames,
  sendPostWithFile,
  sendPostWithoutFile,
  preparePostRequest,
  
  addFields,
  addCustomHeaders,
  
  cookiesRemoveSet,
  mergeCookies,

  uploadAndGrabHtml,
  fetchAndGrabHtml,

  saveFirstLink,
  saveFirstLinkExtended,

  grabLocationHeader,
  grabExtractLinks,

  PasteHandler,
  PasteContext(..),
  PasteContextMap,
  InputField(..),
  InputFields,
  EncodingType(..),
  LinkFilterType(..)
  
  ) where

import Control.Monad.Reader (
  ReaderT,
  MonadReader,
  runReaderT,
  ask)

import Control.Monad.State (
  StateT,
  MonadState,
  MonadIO,
  runStateT,
  get,
  put,
  gets,
  liftIO,
  modify)

import Data.Maybe
import Network.URI
import Network.HTTP
import Network.HTTP.Headers
import Text.Regex.Posix
import Text.HTML.TagSoup
import Network.Browser
import System.IO.Error

import Control.Monad (void)

import qualified Data.Maybe as May
import qualified Data.Map as Map
import qualified Data.List as List
import qualified Network.URI as URI
import qualified Control.Monad.Reader as R

import qualified Tools
import qualified Proxy
import qualified Processing
import qualified Configuration
import Log (msgDebug, msgInfo, dumpString)

-- | Interfaces

-- PasteContext                -- mutable context, ReaderT
-- Configuration.Configuration -- immutable configuration from file, StateT
newtype PasteHandler a = PasteHandlerA {
  runPasteHandlerA :: ReaderT Configuration.Configuration (StateT PasteContext IO) a
} deriving (Monad,
            MonadIO,
            MonadReader Configuration.Configuration,
            MonadState PasteContext,
            Functor)

instance Show (PasteHandler a) where
  show _ = "PasteHandler"

data PasteContext = PasteContext {
  pcUploadLink    :: String,                  -- initial request link
  pcFileTagName   :: String,                  -- tag name of file in POST form
  pcFileName      :: String,                  -- filename in the filesystem
  pcFields        :: InputFields,             -- mandatory POST fields
  pcEncodingType  :: EncodingType,            -- type of encoding: Multipart or UrlEncoded
  pcContents      :: String,                  -- file contents
  pcResultLink    :: Maybe String,            -- link to pasted file
  pcCustomFields  :: Map.Map String String,   -- custom engine fields to pass in a handler chain
  pcAllowRedirect :: Bool,                    -- allow HTTP redirects by HTTP lib
  pcCustomHeaders :: [Header]                 -- custom HTTP request header fields
  } deriving Show

-- | Map {engineName -> pasteContext}
type PasteContextMap a = Map.Map String (PasteContext, PasteHandler a)

-- | Interface for transformation to HTML form

data EncodingType = MultipartFormData | UrlEncoded deriving Show

type InputFields = [InputField]
data InputField = TextField String String
                | EmptyFilenameField Int
                | BinaryFileField String String String
                deriving Show

class Encodable a where
  toString :: a -> EncodingType -> String

-- | Interface implementation

instance Encodable InputField where
  toString (TextField key value) MultipartFormData =
    "Content-Disposition: form-data; name=\"" ++ key ++ "\"\r\n" ++
    --"Content-Type: text/plain; charset=utf-8\r\n" ++
    "\r\n" ++
    value ++ "\r\n"
    
  toString (TextField key value) UrlEncoded = encodeUrl key ++ "=" ++ encodeUrl value where
    encodeUrl = URI.normalizeEscape . URI.escapeURIString (\_ -> False)
  toString (EmptyFilenameField _) UrlEncoded = "<undefined>"
  toString (BinaryFileField {}) UrlEncoded = "<undefined>"

  toString (EmptyFilenameField n) MultipartFormData =
    "Content-Disposition: form-data; name=\"file" ++ show n ++ "\"; filename=\"\"\r\n" ++
    "Content-Type: text/plain\r\n" ++
    "\r\n" ++
    "\r\n"
    
  toString (BinaryFileField name filename payload) MultipartFormData =
    "Content-Disposition: form-data; name=\"" ++ name ++
    "\"; filename=\"" ++ filename ++ "\"\r\n" ++
    contentType filename ++
    "\r\n" ++
    payload ++ "\r\n"
    
    where
      contentType name | name =~ "\\.[jJ][pP][gG]" = "Content-Type: image/jpeg\r\n"
      contentType name | name =~ "\\.[pP][nN][gG]" = "Content-Type: image/png\r\n"
      contentType name = "Content-Type: unknown\r\n"

-- | Encoding

encodeInputField :: InputField -> String -> String
encodeInputField field boundary = "\r\n" ++ toString field MultipartFormData ++ "--" ++ boundary

encodeInputFields :: [InputField] -> String -> EncodingType -> String
encodeInputFields fields boundary MultipartFormData = concat t ++ h where
  encoded = map (`encodeInputField` boundary) fields
  h = head encoded ++ "--"
  t = tail encoded

encodeInputFields fields _ UrlEncoded = List.intercalate "&" $ map encodeField fields where
  encodeField field = toString field UrlEncoded

-- | Prepares request body for sending
encodeContentWithFile :: String -> String -> String -> InputFields -> FilePath -> String
encodeContentWithFile boundary content fileFieldName fields filename =
  "--" ++ boundary ++ 
  encodeInputFields (BinaryFileField fileFieldName filename content : fields) boundary MultipartFormData ++
  "\r\n"

encodeContentWithoutFile :: String -> InputFields -> EncodingType -> String
encodeContentWithoutFile boundary fields encType = compound encType where
  compound MultipartFormData = "--" ++ boundary ++ body ++ "\r\n"
  compound UrlEncoded = body
  body = encodeInputFields fields boundary encType

-- | Implementation

-- | Set "Cookie" header name and merge many SetCookie: headers into single Cookie:
cookiesRemoveSet :: Response String -> Header
cookiesRemoveSet response = mergeCookies headers "; " where
  headers = retrieveHeaders HdrSetCookie response

mergeCookies :: [Header] -> String -> Header
mergeCookies cookies separator = mkHeader HdrCookie $ List.intercalate separator $ map hdrValue cookies

addFields :: PasteContext -> InputFields -> PasteContext
addFields context newFields = context { Engine.pcFields = newFields ++ Engine.pcFields context }

addCustomHeaders :: PasteContext -> [Header] -> PasteContext
addCustomHeaders context newHeaders = context { Engine.pcCustomHeaders = newHeaders ++ Engine.pcCustomHeaders context }

fetch :: Request String -> Bool -> IO (Response String)
fetch req redirect = do
  proxyEnv <- Proxy.getProxyFromEnvironment
  let proxy = proxyEnv

  (uri, rsp) <- browse $ do
    setAllowRedirects redirect -- handle HTTP redirects
    setProxy proxy
    --setDebugLog Nothing
    setOutHandler $ const $ return ()
    request req
  return rsp

preparePostRequest :: Bool -> PasteContext -> Request String
preparePostRequest withFile context = request where
  boundary = "LYNX"
  
  contentType = properContentType (pcEncodingType context) 
  properContentType MultipartFormData = "multipart/form-data; boundary=" ++ boundary
  properContentType UrlEncoded = "application/x-www-form-urlencoded"

  shortName = reverse . takeWhile (\x -> x /= '/' && x /= '\\') . reverse  
  fileContent = pcContents context
  filename = shortName $ pcFileName context
  fileTagName = shortName $ pcFileTagName context
  
  encodedContent = localEncode withFile
  localEncode True = encodeContentWithFile boundary fileContent fileTagName (pcFields context) filename
  localEncode False = encodeContentWithoutFile boundary (pcFields context) (pcEncodingType context)
  
  headers = [Header HdrContentType contentType,
             Header HdrContentLength (show (length encodedContent)),
             Header HdrUserAgent "Links (2.2)",
             Header HdrConnection "Close"]
  uri = fromJust $ parseURI (pcUploadLink context)
  request = Request {rqURI = uri,
                     rqMethod = POST,
                     rqHeaders = headers ++ pcCustomHeaders context,
                     rqBody = encodedContent}

-- | Send HTTP auth form using POST
sendPostWithoutFile :: PasteContext -> IO (Response String)
sendPostWithoutFile context = sendPost context $ preparePostRequest False

sendPostWithFile :: PasteContext -> IO (Response String)
sendPostWithFile context = sendPost context $ preparePostRequest True

sendPost :: PasteContext -> (PasteContext -> Request String) -> IO (Response String)
sendPost context preparator =
  do
    msgDebug "--- sendPost ---"
    let request = preparator context
    
    msgDebug $ "request body len = " ++ show (length (rqBody request))
    dumpString "request.body.dump.bin" $ rqBody request

    response <- fetch request $ pcAllowRedirect context
    dumpString "response.html" $ rspBody response

    return response

-- | List engine names in a single string
engineNames :: PasteContextMap a -> String
engineNames engines = List.intercalate ", " $ Map.keys engines

-- | Runs handler with given configuration and state
runPasteHandler :: FilePath
                -> Configuration.Configuration
                -> PasteContext
                -> PasteHandler a
                -> IO (Maybe String)
runPasteHandler filename config state handler = Tools.withFileContents filename $ \fileContent -> do
  let newState = state { pcContents = fileContent, pcFileName = filename }
  (_, resultContext) <- runStateT (runReaderT (runPasteHandlerA handler) config) newState
  return $ pcResultLink resultContext

-- | Useful built-in helpers which solve common paste problems

data LinkFilterType = FileName | FileExtension | FileEmpty

getFilter :: PasteContext -> LinkFilterType -> String
getFilter context FileName      = Tools.fileName (pcFileName context)
getFilter context FileExtension = Tools.fileExtension (pcFileName context) ++ "$"
getFilter context FileEmpty     = ""

type Grabber = PasteContext -> Response String -> [String]

grabLocationHeader :: Grabber
grabLocationHeader _ response = May.maybeToList $ lookupHeader HdrLocation $ rspHeaders response

grabExtractLinks :: String -> String -> LinkFilterType -> Grabber
grabExtractLinks attr value flt context response =
  Processing.extractLinks (rspBody response) attr value $ getFilter context flt

-- Grabs links from page according to given field names and regexp
uploadAndGrabHtml :: Grabber -> PasteHandler [String]
uploadAndGrabHtml grab = do
  context <- get
  response <- liftIO $ sendPostWithFile context
  return $ grab context response

fetchAndGrabHtml :: String -> Bool -> Grabber -> PasteHandler [String]
fetchAndGrabHtml url redirect grab = do
  context <- get
  response <- liftIO $ fetch (getRequest url) redirect
  return $ grab context response

-- Save first link of the input as it is
saveFirstLink :: [String] -> Engine.PasteHandler ()
saveFirstLink = saveFirstLinkExtended "" ""

-- Save first link with possible prefix and postfix
saveFirstLinkExtended :: String -> String -> [String] -> Engine.PasteHandler ()
saveFirstLinkExtended prefix postfix links = do
  context <- get
  case links of
    (link:_) -> void $ put context { Engine.pcResultLink = Just $ concat [prefix, link, postfix] }
    _        -> return ()