module Primitives (primitives) where

import Control.Applicative ((<$>))
import Control.Monad.Error (throwError)
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 :: [(String      , TermFun)]
primitives = [ ("fst"       , first)
             , ("snd"       , secnd)
             , ("hash"      , unaryId "hash")
             , ("pk"        , unaryId "pk")
             , ("httpReq"   , httpReq)
             , ("httpResp"  , httpResp)
             , ("getmsg"    , getmsg)
             , ("pair"      , binaryId "pair")
             , ("sdec"      , sdec)
             , ("senc"      , binaryId "senc")
             , ("adec"      , adec)
             , ("aenc"      , binaryId "aenc")
             , ("sign"      , binaryId "sign")
             , ("checksign" , checksign)
             , ("mac"       , binaryId "mac")
             , ("headers"   , listId)
             , ("header"    , header)
             , ("cookies"   , listId)
             , ("httpGet"   , constId "httpGet")
             , ("httpHead"  , constId "httpHead")
             , ("httpPost"  , constId "httpPost")
             , ("getHeaders", getHeadersFromData)
             , ("setHeader" , setHeader)
             , ("getHeader" , getHeader)
             , ("getCookie" , getCookie)
             , ("setCookie" , setCookie)
             , ("uri"       , makeUri)
             , ("rspCode"   , responseCode)
             , ("add"       , add)
             , ("cons"      , cons)
             , ("head"      , head')
             , ("tail"      , tail')
             ]

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

setHeader :: TermFun
setHeader [h@(TStr _), TData d] = do 
                      headr <- makeHeader h
                      let name = hdrName headr
                      let val  = hdrValue headr
                      return $ TData $ replaceHeader name val d 
setHeader [h@(TStr _), TList hs] = return $ TList $ h : hs  
setHeader 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 [TData d, c] = 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