> {-# OPTIONS -fglasgow-exts -fno-monomorphism-restriction #-}
> module QuicQuid.HTTPApi (startHTTP) where 
> import System.IO.Unsafe(unsafePerformIO)
> import Data.Maybe(fromJust,isJust,isNothing)
> import Control.Concurrent.Chan
> -- import Control.Concurrent.STM.TChan
> import System.FilePath
> import GHC.Conc
> import HAppS.Server
> import HAppS.Server.SimpleHTTP
> import Control.Exception(handle)
> import Control.Monad
> import Control.Monad.Error
> -- import Control.Monad.Trans(liftIO)
> import qualified Data.ByteString.Lazy.Char8 as L
> import qualified Data.ByteString.Char8 as B
> import Data.Encoding
> import Data.Encoding.UTF8
> import qualified Data.Map as M
> import QuicQuid.Log
> import QuicQuid.Random
> import QuicQuid.Term
> import QuicQuid.Router


The agent that handles the communication with external clients via HTTP.

API Requirements:
- Supports clients written in any language.
- Supports JavaScript clients connecting either from pages on the API server or other sites.
- Allow to transfer any routable message (with no additional size/format limits)
- Supports two-way communication: server agents can send messages to the client at any time.
- Safe: vs rogue scripts and man-in-the-middle attacks ...
- Easy to implement on the client side.
- Efficient (latency and throughput).
- ? Ensure that messages are delivered.
- ? Clients can reconnect to the API server after a server restart with same identifier.
- ? Resistent to Denial of Service attacks (a firewall might take care of this?)
- Fair: clients are given a similar share of bandwidth.
 
Protocol:

Connection creation:
The client opens a connection and sends an empty array of messages
The server replies by sending a unique client identifier to the client's router: Msg{to:"router",..yourAdr:..}

Message exchange:
The client then starts sending, possibly empty, arrays of messages.
When the server receives a call from the client:
- it will deliver the client messages
- if it holds any other pending call(s), it will return them with any pending reply.
  otherwise it will wait till there are any message for the client or up to 30 seconds (whatever happens first) and return the messages.

Invariants:
- There is always a single pending call from the client to the server.
- Calls are answered in the order that they have been opened.
- Pending server-client messages are sent on the oldest open call.
- Client and server both agree on the identifier associated with the client/server connection.
- No messages are transferred from the client to the server till a connection id is agreed.


AJAX api:
<server-url>/api?callback=fnName&messages=msgs
where:
fnName is the name of the callback JavaScript function
msgs   is the URL-coding of the UTF-8 representation of a Term of the form: [[to,body],[to,body]..] where every [[domain,adr],body] is a message. 
session is the sessionID

Additional parameters are accepted but ignored (a JavaScript client might send an additional parameter with a changing value so that the web browser does not cache the request).

Returns a JavaScript document with contents:
<fnName>(reply)
where reply is of the same form as msgs.

TO DO: support POST API.
TODO: handle jsonp GET parameter. 
In the absence of such a parameter, the name of the callback defaults to 'jsonpcallback'. 

BUG/TODO: cleanup unused connections.

> {-# NOINLINE manager #-}
> -- | Stores the info relative to the open sessions,
> manager :: TVar Manager 
> manager = unsafePerformIO . newTVarIO $ M.empty

> type Manager = M.Map Address SessionInfo
> data SessionInfo = SessionInfo {sessionChan::ReadChan,sessionLastConnection::Int} 

> -- |Starts the HTTP connection, this never returns so it has to be the last call from the main. 
> -- ?TO CHK: use HAppS events stream interface directly instead or move to a web server/fastcgi combination
> startHTTP port webDir = simpleHTTP nullConf {port=port} [apiServe,domainServe webDir]

> -- |Catch also IO exceptions
> errHandlerSP handler sps = [ ServerPartT $ \req -> WebT $ do
>			eer <-  handle (\e -> return $ Left $ show e) $ runErrorT $ unWebT $ unServerPartT (multi sps) req
>			case eer of
>				Left  err -> unWebT (handler req err)
>				Right res -> return res
>		]

> -- |Simple multi/virtual domain support.
> -- |Maps <file> in <domain> to <webDir>/<domain>/web/<file> 
> domainServe :: FilePath -> ServerPart Response
> domainServe webDir = withRequest $ \rq -> 
>                      case getHeader "host" rq of
>                          Nothing   -> noHandle
>                          Just host -> (unServerPartT $ fileServe [] (webDir </> (B.unpack host) </> "web")) rq

> apiServe :: ServerPart Response
> apiServe = jop "api" apiInputs api

> -- |Receive the calls from the HTTP clients, each call is handled on a separate thread.
> -- Catch and return errors.
> jop name inputs handler = dir name [withDataFn inputs (\(cb,i)-> errHandlerSP (\req err -> ok.toResponse $ (Exception err,cb)) [anyRequest $ handler (cb,i)])] 

> -- |Parse input parameters.  
> apiInputs = do 
>   cb          <- look "callback"             
>   messagesRaw <- lookBS "messages"
>   let messages = decode UTF8 . B.pack . L.unpack $ messagesRaw 
>   inputs       <- lookPairs 
>   maybeSession <- return $ lookup "session" inputs -- >>= parse -- lookCookieValue sessionCookie
>   return (cb,(maybeSession,messages)) 

> -- |Handle an HTTP call.
> -- Deliver an array of messages and returns all pending messages for the caller.
> api (callback,(maybeSession,messagesS)) = do
>   let Just inMessages = parse messagesS
>   ep <- io $ newEndPoint "/http"  -- TODO: CHK if this is executed anytime (even when not used later).
>   (sessionKey,SessionInfo ch connectionN) <- aio $ do
>     m <- readTVar manager
>     let (sessionKey,sinfo) = if isJust maybeSession 
>                then let Just sKey = maybeSession in 
>                  case M.lookup sKey m of
>                    Just (SessionInfo ch conns) -> (sKey,SessionInfo ch $ conns+1)
>                    Nothing                     -> error $ "Unknown channel " ++ (show sKey) 
>                else let (ch,chKey) = ep in (chKey,SessionInfo ch 1)
>     writeTVar manager $ M.insert sessionKey sinfo m
>     return (sessionKey,sinfo)
>   -- io $ pr (show sessionKey) "server" inMessages
>   io $ if (isNothing maybeSession) 
>     then write sessionKey $ Str "" -- write (subAddress sessionKey "router") $ Obj . M.fromList $ [("yourAdr",sessionKey)] -- ++",myAdr:\"server\"}")
>     else return ()
>   io $ writeMsgs inMessages
>   outMessages <- io $ longRead 0 300 100 sessionKey connectionN
>   -- addCookie 10 (mkCookie sessionCookie "xyx")
>   ok . toResponse $ (Messages outMessages,callback) -- ) `catchError` (\err -> ok $ (Exception err,callback)) -- (\e -> throwError $ show e) . toResponse 
>   where 
>     io f = liftIO $ handle (\e -> fail $ show e) f 
>     aio  = io . atomically
>     longRead count upto delay sessionKey connNum = do
>       -- debugM $ "Waiting on " ++ show sessionKey ++ " conn=" ++ show connNum
>       (SessionInfo ch n) <- atomically $ do
>         m <- readTVar manager
>         return $ fromJust $ M.lookup sessionKey m
>       msgs@(Arr ms) <- readMsgs ch 
>       if count==upto || length ms > 0 || connNum < n
>         then return msgs
>         else threadDelay (delay*1000) >> longRead (count+1) upto delay sessionKey connNum

> -- |Convert the result to JavaScript (in the form required by HAppS):
> data ProtResult = Messages Term | Exception String
 
> instance ToMessage (ProtResult,String) where
>    toContentType _                    = B.pack "text/javascript;charset=utf-8"
>    toMessage  (Messages msgs,   call) = L.pack . B.unpack . encode UTF8 $ call ++ "(" ++ (showJSON1 msgs) ++ ")" 
>    toMessage  (Exception errMsg,call) = L.pack $ call ++ "(new Error(" ++ show errMsg ++ "))" -- CHK: is it correct to show the exception?

> pr from to msgs = debugM $ from ++ " --> " ++ to ++ " : " ++ show msgs -- (foldl (\s m-> s ++ "\n  " ++ show m) "" msgs)