{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-}
module Linden.Server (
   lindenApp
 ) where

import Control.Applicative
import Control.Monad
import qualified Data.ByteString.Lazy as BSL
import qualified Data.ByteString.Lazy.Builder as BSLB
import qualified Data.Aeson as JS
import Data.Maybe
import Data.IORef
import Data.Char
import Data.Bits
import Data.Monoid
import Data.Function
import Data.List
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import Data.Random
import Control.Time
import Data.Time
import Data.UUID (UUID)
import qualified Data.UUID as UUID
import qualified Data.UUID.V1 as V1
import qualified Data.Map as Map
import Data.Digest.Pure.SHA (sha512, showDigest)
import System.FilePath

import qualified Network.HTTP.Types.Method as HTTP
import qualified Network.HTTP.Types.Status as HTTP
import qualified Network.Wai as WAI
import Network.Wai.EventSource
import Network.Wai.Middleware.Gzip
import Network.Wai.Application.Static
import Network.Wai.Middleware.Rewrite
import Network.Wai.UrlMap
import Network.Wai.Middleware.Cors
import Network.Wai.Request (requestSizeCheck)

import Linden.Types

lindenApp :: FilePath -> GardenStore -> BSL.ByteString -> NominalDiffTime -> AxiomSource -> IO Rule -> IO T.Text -> WAI.Application
lindenApp bp (GardenStore gsave gcas _) sec upRate axiom iorule upRule =
    gzip def . simpleCors . rewritePure rr . mapUrls $
          mount "run" eventTree
      <|> mount "rule" reRule
      <|> mount "edit" treeEdit
      <|> mount "art" (staticApp $ defaultWebAppSettings (bp </> "assets"))
      <|> mountRoot (staticApp $ defaultWebAppSettings (bp </> "client/build"))
  where
    rr [] _ = ["index.html"]
    rr ts _ = ts

    genEditKey :: UUID -> String
    genEditKey u = showDigest . sha512 $ sec <> UUID.toByteString u

    editKeyCheck :: UUID -> String -> Bool
    editKeyCheck u k =
        (length gk == length k) && 0 == (foldl1 (.|.) . zipWith (xor `on` ord) k $ gk)
      where gk = genEditKey u

    upDiff :: DiffTime
    upDiff = realToFrac upRate

    keyAuth :: UUID -> String -> (WAI.Response -> IO WAI.ResponseReceived) -> IO WAI.ResponseReceived -> IO WAI.ResponseReceived
    keyAuth u k _ app | editKeyCheck u k = app
    keyAuth _ _ respond _ | otherwise =
      respond $ WAI.responseBuilder HTTP.status403 [] "Bad Edit Key"

    reRule :: WAI.Application
    reRule _ respond = do
      errs <- upRule
      respond $ WAI.responseLBS HTTP.status200 [] . BSL.fromStrict . TE.encodeUtf8 $ errs

    treeEdit :: WAI.Application
    treeEdit req respond | (WAI.requestMethod req == HTTP.methodPost) = do
      reqBody <- WAI.strictRequestBody =<< requestSizeCheck 1024 req
      case JS.eitherDecode' reqBody of
        Left err -> respond $ WAI.responseBuilder HTTP.status400 [] .
                   BSLB.byteString . TE.encodeUtf8 . T.pack $ err
        Right (UserDel gdn k tgt) -> keyAuth gdn k respond $ do
          now <- getCurrentTime
          void . gcas gdn $ \(LS i _ s0 ls (Just (PrettyJSTree t0))) -> do
            return ( Just . LS i now s0 (filter (\lt -> (lId lt) /=tgt) ls) .
                       fmap PrettyJSTree . filterTree (\b -> tgt /= (bId b)) $ t0
                   , ())
          respond $ WAI.responseBuilder HTTP.status200 [] "Ok"
        Right (UserEditLight gdn k ml loc p w c) -> keyAuth gdn k respond $ do
          now <- getCurrentTime
          nlight <- gcas gdn $ \(ls@(LS _ _ s lts _)) -> do
            let (tl, ol) = partition (\l' -> (Exists $ lId l')==ml) lts
            let (s', newLights) =
                    case (tl, ml, length ol < 3) of
                      ([_], Exists l, _) -> (s, [Light l loc p w c])
                      ([], IsNull, True) -> (s+1, [Light s loc p w c])
                      _ -> (s, [])
            let allLights = newLights++ol
            return ( Just $ ls { lsSupply = s'
                               , lsLastUpdate = now
                               , lsLights = allLights }
                     , Just allLights)
          respond $ WAI.responseBuilder HTTP.status200 [] .
                  BSLB.lazyByteString . JS.encode $ nlight
    treeEdit _ respond =
        respond $ WAI.responseLBS HTTP.status405 [] "Bad method"

    eventSendGarden :: Maybe LState -> IO ServerEvent
    eventSendGarden mns = return $
      case mns of
        Nothing -> CloseEvent
        Just ns ->
          ServerEvent (Just "linden") Nothing .
          pure . BSLB.lazyByteString . JS.encode $ ns

    eventTree :: WAI.Application
    eventTree req respond = do
      (u, ek) <- case join . fmap UUID.fromText . listToMaybe . WAI.pathInfo $ req of
           Nothing -> do
             Just uuid <- V1.nextUUID
             now <- getCurrentTime
             ax <- runRVar (axiom uuid now) StdRandom
             gsave ax
             return (uuid, Left $ genEditKey uuid)
           Just u' -> return (u', Right False)
      stepR <- newIORef ek
      eventSourceAppIO (do
        stp <- readIORef stepR
        case stp of
          Left k -> do
            writeIORef stepR (Right False)
            return . ServerEvent (Just "linden-key") Nothing .
              pure . BSLB.lazyByteString . JS.encode . Map.fromList $
                [ ("garden", UUID.toText u)
                , ("key"::T.Text, T.pack k) ]
          Right False -> do
            writeIORef stepR (Right True)
            mns <- gcas u (\ls -> return (Nothing, ls))
            eventSendGarden mns
          _ -> do
            delay upDiff
            now <- getCurrentTime
            rule <- iorule
            mns <- gcas u (\ls ->
                    -- make sure we only update if its been long enough.
                    case (now `diffUTCTime` (lsLastUpdate ls)) <= upRate of
                      True -> return (Nothing, ls)
                      False -> do
                        upped <- step rule now ls
                        return (Just upped, upped))
            eventSendGarden mns) req respond