{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE InterruptibleFFI #-}
{-# LANGUAGE RecordWildCards #-}
module Ohm.XHRIO where

import Control.Arrow
import Control.Concurrent.STM
import Control.Lens
import Control.Monad (void)
import Data.Aeson (ToJSON, FromJSON)
import qualified Data.Aeson as Aeson
import qualified Data.ByteString.Char8 as C8
import qualified Data.ByteString.Lazy as BSL
import Pipes.Concurrent (Output(..))
import Data.Maybe
import Data.List.Split
import Control.Applicative
import Data.Foldable (for_)
import GHCJS.Foreign
import GHCJS.Types

data Request = Request
  { rqWithCredentials :: Bool
  , rqURL :: String
  , rqMethod :: Method
  , rqHeaders :: [(String, String)]
  , rqPayload :: Maybe JSString
  }

mkRequest :: (ToJSON a) => Method -> String -> a -> Request
mkRequest meth url a = Request 
  { rqWithCredentials = False
  , rqURL = url
  , rqMethod = meth
  , rqHeaders = []
  , rqPayload = Just (toJSString . C8.unpack . BSL.toStrict $ Aeson.encode a)
  } 
    
data Method = GET | POST | DELETE | PUT deriving (Eq, Show)

instance ToJSString Method where
  toJSString = toJSString . show

data Response = Response { resStatus :: Int
                         , resHeaders :: [(String, String)]
                         , resText :: String
                         }

request :: Request -> IO Response
request Request{..} = do
  xhr <- jsNewXHR
  jsXHROpen xhr (toJSString rqMethod) (toJSString rqURL)
  jsXHRSetWithCredentials xhr (toJSBool rqWithCredentials)
  for_ rqHeaders $ \(k, v) -> jsXHRSetRequestHeader xhr (toJSString k) (toJSString v)
  jsXHRSend xhr (fromMaybe jsNull rqPayload)
  Response
   <$> jsXHRGetStatus xhr
   <*> (map (second (drop 2) . break (== ':')) . splitOn "\r\n" . fromJSString
          <$> jsXHRGetAllResponseHeaders xhr)
   <*> (fromJSString <$> jsXHRGetResponseText xhr)

--------------------------------------------------------------------------------
data XHR

foreign import javascript unsafe
 "$r = new XMLHttpRequest();\
 \$r.latestProgressMessage = null;\
 \$r.awaitingProgress = null;\
 \$r.incrementalPos = 0;\
 \$r.err = null"
 jsNewXHR :: IO (JSRef XHR)

foreign import javascript unsafe
 "$1.withCredentials = $2;"
  jsXHRSetWithCredentials :: JSRef XHR -> JSBool -> IO ()

foreign import javascript unsafe
 "$1.open($2, $3, true);"
  jsXHROpen :: JSRef XHR -> JSString -> JSString -> IO ()

foreign import javascript unsafe
 "$1.setRequestHeader($2, $3);"
  jsXHRSetRequestHeader :: JSRef XHR -> JSString -> JSString -> IO ()

foreign import javascript interruptible
 "$1.onload = function(e) { $c(); };\
 \$1.onerror = function(e) { $1['h$err'] = true; $c(); };\
 \$1.send($2);"
 jsXHRSend :: JSRef XHR -> JSRef a -> IO ()

foreign import javascript unsafe
 "$1.status"
 jsXHRGetStatus :: JSRef XHR -> IO Int

foreign import javascript unsafe
 "$1.getAllResponseHeaders()"
 jsXHRGetAllResponseHeaders :: JSRef XHR -> IO JSString

foreign import javascript unsafe
 "$1.responseText"
 jsXHRGetResponseText :: JSRef XHR -> IO JSString


_JSON :: (ToJSON a, FromJSON a) => Prism' JSString a
_JSON = prism' encode' decode'
  where encode' = toJSString . C8.unpack . BSL.toStrict . Aeson.encode
        decode' = Aeson.decode . BSL.fromStrict . C8.pack . fromJSString
        
--------------------------------------------------------------------------------
ajax :: (ToJSON a, FromJSON b) => Method -> String -> a -> Output b -> IO ()
ajax meth url payload output = do
  resp <- request $ mkRequest meth url payload
  case resp of
    Response 200 _ r -> do
      case decode' r of
        Just b -> void . atomically $ send output b
        _      -> return ()
    _                -> return ()
  where decode' = Aeson.decode . BSL.fromStrict . C8.pack

get, post :: (ToJSON a) => String -> a -> Output String -> IO ()
get = ajax GET
post = ajax POST

--------------------------------------------------------------------------------
ajax_ :: (ToJSON a) => Method -> String -> a -> IO Response
ajax_ meth url payload = request $ mkRequest meth url payload

get_, post_ :: (ToJSON a) => String -> a -> IO Response
get_ = ajax_ GET
post_ = ajax_ POST
