{-# LANGUAGE RecordWildCards, OverloadedStrings #-}

module Development.Bake.Core.Message(
    Message(..), Ping(..), Question(..), Answer(..),
    sendMessage, messageToInput, messageFromInput, questionToOutput
    ) where

import Development.Bake.Core.Type
import General.Web
import General.BigString
import Control.Applicative
import Control.Monad
import Control.DeepSeq
import Data.Aeson hiding (Success)
import System.Time.Extra
import Safe
import qualified Data.ByteString.Lazy.Char8 as LBS
import Prelude


data Message
    -- Send by the user
    = SetState Author State
    | AddPatch Author Patch
    | DelPatch Patch
    | Requeue
    | Pause
    | Unpause
    | AddSkip Author Test
    | DelSkip Test
    -- Sent by the client
    | Pinged Ping
    | Finished {question :: Question, answer :: Answer}
    deriving Show

instance NFData Message where
    rnf (AddPatch x y) = rnf x `seq` rnf y
    rnf (DelPatch x) = rnf x
    rnf Requeue = ()
    rnf (SetState x y) = rnf x `seq` rnf y
    rnf Pause = ()
    rnf Unpause = ()
    rnf (AddSkip x y) = rnf x `seq` rnf y
    rnf (DelSkip x) = rnf x
    rnf (Pinged x) = rnf x
    rnf (Finished x y) = rnf x `seq` rnf y

data Question = Question
    {qCandidate :: (State, [Patch])
    ,qTest :: Maybe Test
    ,qThreads :: Int
    ,qClient :: Client
    }
    deriving (Show,Eq,Ord)

instance NFData Question where
    rnf (Question a b c d) = rnf (a,b,c,d)

data Answer = Answer
    {aStdout :: BigString
    ,aDuration :: Maybe Seconds -- Nothing for a skip
    ,aTests :: [Test]
    ,aSuccess :: Bool
    }
    deriving Show

instance NFData Answer where
    rnf (Answer a b c d) = rnf a `seq` rnf b `seq` rnf c `seq` rnf d

data Ping = Ping
    {pClient :: Client
    ,pAuthor :: Author
    ,pProvide :: [String] -- matches with testRequire
    ,pMaxThreads :: Int
    ,pNowThreads :: Int
    }
    deriving (Show,Eq)

instance NFData Ping where
    rnf (Ping a b c d e) = rnf a `seq` rnf b `seq` rnf c `seq` rnf d `seq` rnf e


instance ToJSON Question where
    toJSON Question{..} = object
        ["candidate" .= toJSONCandidate qCandidate
        ,"test" .= qTest
        ,"threads" .= qThreads
        ,"client" .= qClient]

instance FromJSON Question where
    parseJSON (Object v) = Question <$>
        (fromJSONCandidate =<< (v .: "candidate")) <*> (v .: "test") <*> (v .: "threads") <*> (v .: "client")
    parseJSON _ = mzero

toJSONCandidate (s, ps) = object ["state" .= s, "patches" .= ps]

fromJSONCandidate (Object v) = (,) <$> (v .: "state") <*> (v .: "patches")
fromJSONCandidate _ = mzero


messageToInput :: Message -> Input
messageToInput (AddPatch author patch) = Input ["api","add"] [("author",author),("patch",fromPatch patch)] []
messageToInput (DelPatch patch) = Input ["api","del"] [("patch",fromPatch patch)] []
messageToInput Requeue = Input ["api","requeue"] [] []
messageToInput (SetState author state) = Input ["api","set"] [("author",author),("state",fromState state)] []
messageToInput Pause = Input ["api","pause"] [] []
messageToInput Unpause = Input ["api","unpause"] [] []
messageToInput (AddSkip author test) = Input ["api","addskip"] [("author",author),("test",fromTest test)] []
messageToInput (DelSkip test) = Input ["api","delskip"] [("test",fromTest test)] []
messageToInput (Pinged Ping{..}) = Input ["api","ping"] 
    ([("client",fromClient pClient),("author",pAuthor)] ++
     [("provide",x) | x <- pProvide] ++
     [("maxthreads",show pMaxThreads),("nowthreads",show pNowThreads)]) []
messageToInput (Finished Question{..} Answer{..}) = Input ["api","finish"] []
    [("state", bigStringFromString $ fromState $ fst qCandidate)
    ,("patch", bigStringFromString $ unlines $ map fromPatch $ snd qCandidate)
    ,("test", bigStringFromString $ maybe "" fromTest qTest)
    ,("threads", bigStringFromString $ show qThreads)
    ,("client", bigStringFromString $ fromClient qClient)
    ,("stdout", aStdout)
    ,("duration", bigStringFromString $ maybe "" show aDuration)
    ,("tests", bigStringFromString $ unlines $ map fromTest aTests)
    ,("success", bigStringFromString $ show aSuccess)]


-- return either an error message (not a valid message), or a message
messageFromInput :: Input -> Either String Message
messageFromInput (Input [msg] args body)
    | msg == "add" = AddPatch <$> str "author" <*> (toPatch <$> str "patch")
    | msg == "del" = DelPatch <$> (toPatch <$> str "patch")
    | msg == "addskip" = AddSkip <$> str "author" <*> (toTest <$> str "test")
    | msg == "delskip" = DelSkip <$> (toTest <$> str "test")
    | msg == "requeue" = pure Requeue
    | msg == "set" = SetState <$> str "author" <*> (toState <$> str "state")
    | msg == "pause" = pure Pause
    | msg == "unpause" = pure Unpause
    | msg == "ping" = Pinged <$> (Ping <$> (toClient <$> str "client") <*>
        str "author" <*> strs "provide" <*> int "maxthreads" <*> int "nowthreads")
    where strs x = Right $ map snd $ filter ((==) x . fst) args
          str x | Just v <- lookup x args = Right v
                | otherwise = Left $ "Missing field " ++ show x ++ " from " ++ show msg
          int x = readNote "messageFromInput, expecting Int" <$> str x
messageFromInput (Input [msg] args body)
    | msg == "finish" = do
        let f x = case lookup x body of Nothing -> Left $ "Missing field " ++ show x ++ " from " ++ show (map fst body); Just x -> Right x
        state <- toState . bigStringToString <$> f "state"
        patch <- map toPatch . lines . filter (/= '\r') . bigStringToString <$> f "patch"
        qTest <- (\x -> if null x then Nothing else Just $ toTest x) . bigStringToString <$> f "test"
        qThreads <- read . bigStringToString <$> f "threads"
        qClient <- toClient . bigStringToString <$> f "client"
        aStdout <- f "stdout"
        aDuration <- (\x -> if null x then Nothing else Just $ read x) . bigStringToString <$> f "duration"
        aTests <- map toTest . lines . filter (/= '\r') . bigStringToString <$> f "tests"
        aSuccess <- read . bigStringToString <$> f "success"
        return $ Finished Question{qCandidate=(state,patch),..} Answer{..}
messageFromInput (Input msg args body) = Left $ "Invalid API call, got " ++ show msg


questionToOutput :: Maybe Question -> Output
questionToOutput = OutputString . LBS.unpack . encode


sendMessage :: (Host,Port) -> Message -> IO (Maybe Question)
sendMessage hp msg = do
    res <- send hp $ messageToInput msg
    return $ decode res