module Primitives (primitives) where

import Control.Applicative ((<$>))
import Control.Monad.Error (throwError)
import qualified Crypto.Hash as Crypto
import Data.Byteable (toBytes)
import qualified Data.ByteString.Char8 as C8
import Network.HTTP.Base (Request(..), Response(..), RequestMethod(..), mkRequest)
import Network.HTTP.Cookie (Cookie, cookiesToHeader)
import Network.HTTP.Headers (HasHeaders(..), Header, HeaderName(..), hdrName, hdrValue, findHeader, parseHeader, replaceHeader, setHeaders)
import Network.URI (parseURI)

import TypDefs

primitives :: [(Name          , TermFun)]
primitives = [ ("fst"         , first)
             , ("snd"         , secnd)
             , ("hash"        , hash)
             , ("pk"          , unaryId "pk")
             , ("httpReq"     , httpReq)
             , ("httpResp"    , httpResp)
             , ("getmsg"      , getmsg)
             , ("sdec"        , sdec)
             , ("senc"        , binaryId "senc")
             , ("adec"        , adec)
             , ("aenc"        , binaryId "aenc")
             , ("sign"        , binaryId "sign")
             , ("checksign"   , checksign)
             , ("mac"         , mac)
             , ("headers"     , listId)
             , ("header"      , header)
             , ("cookies"     , listId)
             , ("httpGet"     , constId "httpGet")
             , ("httpHead"    , constId "httpHead")
             , ("httpPost"    , constId "httpPost")
             , ("getHeaders"  , getHeadersFromData)
             , ("insertHeader", insertHeader)
             , ("getHeader"   , getHeader)
             , ("getCookie"   , getCookie)
             , ("setCookie"   , setCookie)
             , ("uri"         , makeUri)
             , ("rspCode"     , responseCode)
             , ("add"         , add)
             , ("cons"        , cons)
             , ("head"        , head')
             , ("tail"        , tail')
             , ("append"      , append)
             ]



constId :: String -> TermFun
constId name [] = return $ TFun name []
constId name e  = throwError $ NumArgs name 0 (map Term e)

unaryId :: String -> TermFun
unaryId name [x] =  return $ TFun name [x] 
unaryId name e  = throwError $ NumArgs name 1 (map Term e)

binaryId :: String ->  TermFun
binaryId name [x,y] = return $ TFun name [x,y] 
binaryId name e  = throwError $ NumArgs name 2 (map Term e)

listId :: TermFun
listId ts = return $ TList ts

getmsg :: TermFun
getmsg [TFun "sign" [_,y]] = return y
getmsg e = throwError $ TypeMismatch "sign" $ map Term e

first :: TermFun
first [TPair p] = return $ fst p
first e = throwError $ TypeMismatch "pair" $ map Term e 

secnd :: TermFun
secnd [TPair p] = return $ snd p
secnd e = throwError $ TypeMismatch "pair" $ map Term e 

sdec :: TermFun
sdec [k1, TFun "senc" [k2,y]]
    |k1 == k2  = return y
    |otherwise = throwError $ Default "keys not the same in sdec"
sdec e = throwError $ TypeMismatch "(var,senc(var,var))" $ map Term e

adec :: TermFun
adec [x , TFun "aenc" [TFun "pk" [k], y ]]
    | x == k = return y
    | otherwise= throwError $ Default "keys not same in adec" 
adec e = throwError $ TypeMismatch "(var,aenc(pk(var),var))" $ map Term e

checksign :: TermFun
checksign [TFun "pk" [k1], TFun "sign" [k2,_] ] = return $ TBool (k1 == k2)
checksign e = throwError $ TypeMismatch "(pk(var),sign(var,var))" $ map Term e


httpReq :: TermFun
httpReq [TStr url, TList hs , reqMethod] = do
    uri <- case parseURI http' of 
                Just x  -> return x
                Nothing -> throwError $ Default "Malformed uri"
    hss <- makeHeaders hs 
    let req = mkRequest method uri :: Request String in 
        return $ TData $ Req $ setHeaders req hss
    where
        http'  = if take 7 url /= http'' then http'' ++ url else url
        http'' = "http://" 
        method 
            | reqMethod == constFun "httpGet"  = GET 
            | reqMethod == constFun "httpHead" = HEAD 
            | reqMethod == constFun "httpPost" = POST 
            | otherwise = GET
            where constFun x = TFun x [] 
httpReq e = throwError $ TypeMismatch "(url,headers,method)" $ map Term e

httpResp :: TermFun
httpResp [TNum code, TStr reason , TList hs ,TStr bdy] = do
        headers <- makeHeaders hs
        return $ TData $ Resp $ Response (parseCode code) reason headers bdy
        where parseCode c =  case digits c of 
                                    [x,y,z] -> (x,y,z)
                                    _       -> (-1,-1,-1)
httpResp e = throwError $ TypeMismatch "(code,reason,headers,body)" $ map Term e

makeHeaders :: [Term] -> ThrowsError [Header]
makeHeaders = mapM makeHeader

makeHeader :: Term -> ThrowsError Header
makeHeader (TFun "cookies" cs) = do
        cookies <- mapM makeCookie cs 
        return $ cookiesToHeader cookies
makeHeader (TStr s) = case parseHeader s of
            Left _  -> throwError $ Default "malformed header"
            Right h -> return h
makeHeader _ = throwError $ Default "not a header"

header :: TermFun
header [TStr n , TStr v] = TStr . show <$> makeHeader (TStr (n ++ ":" ++ v))
header e = throwError $ TypeMismatch "(headerName, headerValue)" $ map Term e

makeCookie :: Term -> ThrowsError Cookie
makeCookie (TStr c) = return $ read c
makeCookie _ = throwError $ Default "malformed cookie"

getHeadersFromData :: TermFun
getHeadersFromData [TData d] = return $ TList $ map (TStr . show) $ getHeaders d
getHeadersFromData e = throwError $ TypeMismatch "httpData" $ map Term e

getHeader :: TermFun
getHeader [TStr headr, TData d] = do
        h <- case parseHeader $ headr ++ ":" of
            Right h -> return h
            _       -> throwError $ Default $ "Not a header: " ++ headr
        case findHeader (hdrName h) d of 
            Just hr -> return $ TStr hr
            _       -> throwError $ Default $ headr ++ " not in " ++ show d
getHeader e = throwError $ TypeMismatch "httpData" $ map Term e

insertHeader :: TermFun
insertHeader [h@(TStr _), TData d] = do 
                      headr <- makeHeader h
                      let name = hdrName headr
                      let val  = hdrValue headr
                      return $ TData $ replaceHeader name val d 
insertHeader [h@(TStr _), TList hs] = return $ TList $ h : hs  
insertHeader e = throwError $ TypeMismatch "(header,httpData|headers)" $ map Term e

getCookie :: TermFun
getCookie [TData d] = 
    case findHeader HdrCookie d of
        Just x -> return $ TStr x
        Nothing -> throwError $ Default "cookie not found"
getCookie e = throwError $ TypeMismatch "httpData" $ map Term e
    
setCookie :: TermFun
setCookie [c, TData d] = do
    cookie <- makeCookie c
    let cookieHeader = cookiesToHeader [cookie]
    let n = hdrName cookieHeader
    let s = hdrValue cookieHeader
    return $ TData $ replaceHeader n s d 
setCookie e = throwError $ TypeMismatch "(httpData, cookie)" $ map Term e

makeUri :: TermFun
makeUri [TStr host,TStr path] = return $ TStr $ host ++ "/" ++ path
makeUri e = throwError $ TypeMismatch "(string,string)" $ map Term e

responseCode :: TermFun
responseCode [TData d] = case d of
                        Req  _ -> throwError $ Default "Trying to extract Response Code from HttpRequest"
                        Resp r -> return $ TNum $ let (x,y,z) = rspCode r in fromIntegral (100 * x + 10 * y + z)
responseCode e = throwError $ TypeMismatch "(string,string)" $ map Term e

digits :: Integer -> [Int]
digits n = map (read . return) $ show n

add :: TermFun
add [TNum a, TNum b] = return $ TNum $ a + b
add e = throwError $ TypeMismatch "(num,num)" $ map Term e

cons :: TermFun
cons [a, TList x] = return $ TList (a:x)
cons e = throwError $ TypeMismatch "list" $ map Term e

head' :: TermFun
head' [TList []] = throwError $ Default "head of empty list" 
head' [TList xs] = return $ head xs
head' e = throwError $ TypeMismatch "list" $ map Term e

tail' :: TermFun
tail' [TList []] = throwError $ Default "tail of empty list" 
tail' [TList x] = return $ TList $ tail x
tail' e = throwError $ TypeMismatch "list" $ map Term e

hash :: TermFun
hash [TBS msg]  = return $ TBS $ toBytes (Crypto.hash msg :: Crypto.Digest Crypto.MD5)
hash [TStr msg] = let mBS = C8.pack msg in return $ TBS $ toBytes (Crypto.hash mBS :: Crypto.Digest Crypto.MD5)
hash e = throwError $ TypeMismatch "bytestring" $ map Term e
        
mac :: TermFun
mac [TBS key,TBS msg]  = return $ TBS $ toBytes $ Crypto.hmacGetDigest $ Crypto.hmacAlg Crypto.MD5 key msg
mac [TBS key,TStr msg] = let mBS = C8.pack msg in return $ TBS $ toBytes $ Crypto.hmacGetDigest $ Crypto.hmacAlg Crypto.MD5 key mBS
mac e = throwError $ TypeMismatch "(bytestring,bytestring)" $ map Term e

append :: TermFun
append [TList x, TList y] = return $ TList $ x ++ y 
append e = throwError $ TypeMismatch "(list,list)" $ map Term e