{-# LANGUAGE CPP, OverloadedStrings, CPP, PatternGuards, TypeApplications #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

module HsDev.Server.Base (
        initLog, runServer, Server,
        setupServer, shutdownServer,
        startServer, startServer_, stopServer, withServer, withServer_, inServer, clientCommand, parseCommand, readCommand,
        sendServer, sendServer_,
        findPath,
        processRequest, processClient, processClientSocket,

        unMmap, makeSocket, sockAddr,

        module HsDev.Server.Types,
        module HsDev.Server.Message
        ) where

import Control.Concurrent
import Control.Concurrent.Async
import qualified Control.Concurrent.Chan as C
import Control.Lens (set, traverseOf, view)
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Loops
import Control.Monad.Reader
import Control.Monad.Catch (bracket_, bracket, finally)
import Data.Aeson hiding (Result, Error)
import Data.Default
import qualified Data.ByteString.Char8 as BS
import Data.ByteString.Lazy.Char8 (ByteString)
import qualified Data.ByteString.Lazy.Char8 as L
import Data.Maybe
import Data.String (fromString)
import qualified Data.Text as T (pack)
import Data.Time.Clock.POSIX
import Options.Applicative (info, progDesc)
import System.Log.Simple hiding (Level(..), Message)
import qualified System.Log.Simple.Base as Log (level_)
import qualified System.Log.Simple as Log
import Network.Socket
import qualified Network.Socket.ByteString.Lazy as Net (getContents, sendAll)
import System.FilePath
import System.IO
import Text.Format ((~~))

import Control.Concurrent.Util
import qualified Control.Concurrent.FiniteChan as F
import Data.LookupTable
import Data.Maybe.JustIf
import System.Directory.Paths
import qualified System.Directory.Watcher as Watcher

import qualified HsDev.Client.Commands as Client
import qualified HsDev.Database.SQLite as SQLite
import HsDev.Error
import qualified HsDev.Database.Update as Update
import HsDev.Inspect (getDefines)
import HsDev.Tools.Ghc.Worker hiding (Session)
import HsDev.Server.Types
import HsDev.Server.Message
import HsDev.Symbols.Location (ModuleLocation(..), globalDb)
import qualified HsDev.Watcher as W
import HsDev.Util

#if mingw32_HOST_OS
import Data.Aeson.Types hiding (Result, Error)
import System.Win32.FileMapping.Memory (withMapFile, readMapFile)
import System.Win32.FileMapping.NamePool
#else
import System.Posix.Files (removeLink)
#endif

-- | Inits log chan and returns functions (print message, wait channel)
initLog :: ServerOpts -> IO SessionLog
initLog sopts = do
        msgs <- C.newChan
        l <- newLog (logCfg [("", Log.level_ . T.pack . serverLogLevel $ sopts)]) $ concat [
                [logHandler | not $ serverSilent sopts],
                [chaner msgs],
                [handler text (file f) | f <- maybeToList (serverLog sopts)]]
        let
                listenLog = C.dupChan msgs >>= C.getChanContents
        return $ SessionLog l listenLog (stopLog l)
        where
                logHandler
                        | serverLogNoColor sopts = handler text console
                        | otherwise = handler text coloredConsole

-- | Run server
runServer :: ServerOpts -> ServerM IO () -> IO ()
runServer sopts act = bracket (initLog sopts) sessionLogWait $ \slog -> maybeWithWatcher $ \mwatcher -> withLog (sessionLogger slog) $ do
        waitSem <- liftIO $ newQSem 0
        sqlDb <- liftIO $ SQLite.initialize (fromMaybe SQLite.sharedMemory $ serverDbFile sopts)
        clientChan <- liftIO F.newChan
#if mingw32_HOST_OS
        mmapPool <- Just <$> liftIO (createPool "hsdev")
#endif
        ghcw <- ghcWorker
        liftIO $ inWorker ghcw $ tmpSession globalDb []
        defs <- liftIO getDefines

        session <- liftIO $ fixIO $ \sess -> do
                let
                        setFileCts fpath Nothing = void $ withSession sess $ postSessionUpdater $ do
                                Log.sendLog Log.Trace $ "dropping file contents for {}" ~~ fpath
                                SQLite.execute "delete from file_contents where file = ?;" (SQLite.Only fpath)
                        setFileCts fpath (Just cts) = do
                                tm <- getPOSIXTime
                                withSession sess $ do
                                        notChanged <- SQLite.query @_ @(SQLite.Only Bool) "select contents == ? from file_contents where file = ?;" (cts, fpath)
                                        let
                                                notChanged' = any SQLite.fromOnly notChanged
                                        void $ postSessionUpdater $ do
                                                Log.sendLog Log.Trace $ "setting file contents for {} with mtime = {}" ~~ fpath ~~ show tm
                                                SQLite.execute "insert or replace into file_contents (file, contents, mtime) values (?, ?, ?);" (fpath, cts, (fromRational (toRational tm) :: Double))
                                                whenJustM (askSession sessionWatcher) $ \watcher -> unless notChanged' $ liftIO $
                                                        writeChan (W.watcherChan watcher) (W.WatchedModule, W.Event W.Modified (view path fpath) tm)

                uw <- startWorker (withSession sess . withSqlConnection) id logAll
                resolveEnvTable <- newLookupTable

                return $ Session
                        sqlDb
                        (fromMaybe SQLite.sharedMemory $ serverDbFile sopts)
                        slog
                        mwatcher
                        setFileCts
#if mingw32_HOST_OS
                        mmapPool
#endif
                        ghcw
                        uw
                        resolveEnvTable
                        (do
                                withLog (sessionLogger slog) $ Log.sendLog Log.Trace "stopping server"
                                signalQSem waitSem)
                        (waitQSem waitSem)
                        clientChan
                        defs

        _ <- fork $ do
                emptyTask <- async $ return ()
                updaterTask <- newMVar emptyTask
                tasksVar <- newMVar []
                whenJust mwatcher $ \watcher -> Update.onEvents_ watcher $ \evs -> withSession session $
                        void $ Client.runClient def $ Update.processEvents (withSession session . inSessionUpdater . void . Client.runClient def . Update.applyUpdates def) updaterTask tasksVar evs
        liftIO $ runReaderT (runServerM $ (watchDb >> act) `finally` closeSession) session
        where
                maybeWithWatcher fn
                        | serverWatchFS sopts = Watcher.withWatcher (fn . Just)
                        | otherwise = fn Nothing
                closeSession = do
                        askSession sessionUpdater >>= liftIO . joinWorker
                        Log.sendLog Log.Info "updater worker stopped"
                        askSession sessionGhc >>= liftIO . joinWorker
                        Log.sendLog Log.Info "ghc worker stopped"
                        askSession sessionSqlDatabase >>= liftIO . SQLite.close
                        Log.sendLog Log.Info "sql connection closed"


-- | Set initial watch: package-dbs, projects and standalone sources
watchDb :: SessionMonad m => m ()
watchDb = do
        whenJustM (askSession sessionWatcher) $ \w -> do
                -- TODO: Implement watching package-dbs
                cabals <- SQLite.query_ "select cabal from projects;"
                projects <- mapM (SQLite.loadProject . SQLite.fromOnly) cabals
                liftIO $ mapM_ (\proj -> W.watchProject w proj []) projects

                files <- SQLite.query_ "select file from modules where file is not null and cabal is null;"
                liftIO $ mapM_ (\(SQLite.Only f) -> W.watchModule w (FileModule f Nothing)) files

type Server = Worker (ServerM IO)

-- | Start listening for incoming connections
setupServer :: ServerOpts -> ServerM IO ()
setupServer sopts = do
        q <- liftIO $ newQSem 0
        clientChan <- askSession sessionClients
        session <- getSession
        _ <- liftIO $ async $ withSession session $ Log.scope "listener" $ flip finally serverExit $
                bracket (liftIO $ makeSocket (serverPort sopts)) (liftIO . close) $ \s -> do
                        liftIO $ do
                                setSocketOption s ReuseAddr 1
                                addr' <- inet_addr "127.0.0.1"
                                bind s (sockAddr (serverPort sopts) addr')
                                listen s maxListenQueue
                        forever $ logAsync (Log.sendLog Log.Fatal . fromString) $ logIO "exception: " (Log.sendLog Log.Error . fromString) $ do
                                Log.sendLog Log.Trace "accepting connection..."
                                liftIO $ signalQSem q
                                (s', addr') <- liftIO $ accept s
                                Log.sendLog Log.Trace $ "accepted {}" ~~ show addr'
                                fork $ withSession session $ Log.scope (T.pack $ show addr') $
                                        logAsync (Log.sendLog Log.Fatal . fromString) $ logIO "exception: " (Log.sendLog Log.Error . fromString) $
                                                flip finally (liftIO $ close s') $
                                                        bracket (liftIO newEmptyMVar) (liftIO . (`putMVar` ())) $ \done -> do
                                                                me <- liftIO myThreadId
                                                                let
                                                                        timeoutWait = withSession session $ do
                                                                                notDone <- liftIO $ isEmptyMVar done
                                                                                when notDone $ do
                                                                                        Log.sendLog Log.Trace $ "waiting for {} to complete" ~~ show addr'
                                                                                        waitAsync <- liftIO $ async $ do
                                                                                                threadDelay 1000000
                                                                                                killThread me
                                                                                        liftIO $ void $ waitCatch waitAsync
                                                                liftIO $ void $ F.sendChan clientChan timeoutWait
                                                                processClientSocket (show addr') s'

        Log.sendLog Log.Trace "waiting for starting accept thread..."
        liftIO $ waitQSem q
        logIO "error writing to stdout: " (Log.sendLog Log.Error . fromString) $ liftIO $ putStrLn $ "Server started at port {}" ~~ serverPort sopts
        Log.sendLog Log.Info $ "Server started at port {}" ~~ serverPort sopts

-- | Shutdown server
shutdownServer :: ServerOpts -> ServerM IO ()
shutdownServer sopts = do
        Log.sendLog Log.Trace "waiting for accept thread..."
        serverWait
        Log.sendLog Log.Trace "accept thread stopped"
        liftIO $ unlink (serverPort sopts)
        Log.sendLog Log.Trace "waiting for clients..."
        serverWaitClients
        Log.sendLog Log.Info "server stopped"

startServer :: ServerOpts -> IO Server
startServer sopts = startWorker (runServer sopts) (bracket_ (setupServer sopts) (shutdownServer sopts)) logAll

-- Tiny version with no network stuff
startServer_ :: ServerOpts -> IO Server
startServer_ sopts = startWorker (runServer sopts) id logAll

stopServer :: Server -> IO ()
stopServer s = sendServer_ s ["exit"] >> joinWorker s

withServer :: ServerOpts -> (Server -> IO a) -> IO a
withServer sopts = bracket (startServer sopts) stopServer

withServer_ :: ServerOpts -> (Server -> IO a) -> IO a
withServer_ sopts = bracket (startServer_ sopts) stopServer

inServer :: Server -> ServerM IO a -> IO a
inServer = inWorker

clientCommand :: CommandOptions -> Command -> ServerM IO Result
clientCommand copts c = do
        c' <- liftIO $ canonicalize c
        Client.runClient copts (Client.runCommand c')

parseCommand :: [String] -> Either String Command
parseCommand = parseArgs "hsdev" (info cmdP (progDesc "hsdev tool"))

readCommand :: [String] -> Command
readCommand = either error id . parseCommand

sendServer :: Server -> CommandOptions -> [String] -> IO Result
sendServer srv copts args = case parseCommand args of
        Left e -> hsdevError $ RequestError e (unwords args)
        Right c -> inServer srv (clientCommand copts c)

sendServer_ :: Server -> [String] -> IO Result
sendServer_ srv = sendServer srv def

chaner :: C.Chan Log.Message -> Consumer Log.Message
chaner ch = return $ C.writeChan ch

findPath :: MonadIO m => CommandOptions -> FilePath -> m FilePath
findPath copts f = liftIO $ canonicalize (normalise f') where
        f' = absolutise (fromFilePath $ commandOptionsRoot copts) f

-- | Process request, notifications can be sent during processing
processRequest :: SessionMonad m => CommandOptions -> Command -> m Result
processRequest copts c = do
        c' <- paths (findPath copts) c
        s <- getSession
        withSession s $ Client.runClient copts $ Client.runCommand c'

-- | Process client, listen for requests and process them
processClient :: SessionMonad m => String -> F.Chan ByteString -> (ByteString -> IO ()) -> m ()
processClient name rchan send' = do
        Log.sendLog Log.Info "connected"
        respChan <- liftIO newChan
        fork $ getChanContents respChan >>= mapM_ (send' . encodeMessage)
        linkVar <- liftIO $ newMVar $ return ()
        s <- getSession
        exit <- askSession sessionExit
        let
                answer :: SessionMonad m => Msg (Message Response) -> m ()
                answer m = do
                        unless (isNotification $ view (msg . message) m) $
                                Log.sendLog Log.Trace $ "responsed << {}" ~~ ellipsis (fromUtf8 (encode $ view (msg . message) m))
                        liftIO $ writeChan respChan m
                        where
                                ellipsis :: String -> String
                                ellipsis str
                                        | length str < 100 = str
                                        | otherwise = take 100 str ++ "..."

        flip finally (disconnected linkVar) $
                whileJust_ (liftIO $ F.getChan rchan) $ \req' -> do
                        Log.sendLog Log.Trace $ "received >> {}" ~~ fromUtf8 req'
                        case decodeMessage req' of
                                Left em -> do
                                        Log.sendLog Log.Warning $ "Invalid request {}" ~~ fromUtf8 req'
                                        answer $ set msg (Message Nothing $ responseError $ RequestError "invalid request" $ fromUtf8 req') em
                                Right m -> fork $ withSession s $ Log.scope (T.pack name) $ Log.scope "req" $
                                        Log.scope (T.pack $ fromMaybe "_" (view (msg . messageId) m)) $ do
                                                resp' <- flip (traverseOf (msg . message)) m $ \(Request c cdir noFile tm silent) -> do
                                                        let
                                                                onNotify n
                                                                        | silent = return ()
                                                                        | otherwise = traverseOf (msg . message) (const $ mmap' noFile (Response $ Left n)) m >>= answer
                                                        Log.sendLog Log.Trace $ "requested >> {}" ~~ fromUtf8 (encode c)
                                                        resp <- liftIO $ fmap (Response . Right) $ handleTimeout tm $ hsdevLiftIO $ withSession s $
                                                                processRequest
                                                                        CommandOptions {
                                                                                commandOptionsRoot = cdir,
                                                                                commandOptionsNotify = withSession s . onNotify,
                                                                                commandOptionsLink = void (swapMVar linkVar exit),
                                                                                commandOptionsHold = forever (F.getChan rchan) }
                                                                        c
                                                        mmap' noFile resp
                                                answer resp'
        where
                handleTimeout :: Int -> IO Result -> IO Result
                handleTimeout 0 = id
                handleTimeout tm = fmap (fromMaybe $ Error $ OtherError "timeout") . timeout tm

                mmap' :: SessionMonad m => Bool -> Response -> m Response
#if mingw32_HOST_OS
                mmap' False r = do
                        mpool <- askSession sessionMmapPool
                        case mpool of
                                Just pool -> liftIO $ mmap pool r
                                Nothing -> return r
#endif
                mmap' _ r = return r

                -- Call on disconnected, either no action or exit command
                disconnected :: SessionMonad m => MVar (IO ()) -> m ()
                disconnected var = do
                        Log.sendLog Log.Info "disconnected"
                        liftIO $ join $ takeMVar var

-- | Process client by socket
processClientSocket :: SessionMonad m => String -> Socket -> m ()
processClientSocket name s = do
        recvChan <- liftIO F.newChan
        fork $ finally
                (Net.getContents s >>= mapM_ (F.sendChan recvChan) . L.lines)
                (F.closeChan recvChan)
        processClient name recvChan (sendLine s)
        where
                sendLine :: Socket -> ByteString -> IO ()
                sendLine sock bs = Net.sendAll sock $ L.snoc bs '\n'

#if mingw32_HOST_OS
newtype MmapFile = MmapFile String

instance ToJSON MmapFile where
        toJSON (MmapFile f) = object ["file" .= f]

instance FromJSON MmapFile where
        parseJSON = withObject "file" $ \v -> MmapFile <$> v .:: "file"

-- | Push message to mmap and return response which points to this mmap
mmap :: Pool -> Response -> IO Response
mmap mmapPool r
        | L.length msg' <= 1024 = return r
        | otherwise = do
                rvar <- newEmptyMVar
                _ <- forkIO $ flip finally (tryPutMVar rvar r) $ void $ withName mmapPool $ \mmapName -> runExceptT $ catchError
                        (withMapFile mmapName (L.toStrict msg') $ liftIO $ do
                                _ <- tryPutMVar rvar $ result $ MmapFile mmapName
                                -- give 10 seconds for client to read data
                                threadDelay 10000000)
                        (\_ -> liftIO $ void $ tryPutMVar rvar r)
                takeMVar rvar
        where
                msg' = encode r
#endif

-- | If response points to mmap, get its contents and parse
unMmap :: Response -> IO Response
#if mingw32_HOST_OS
unMmap (Response (Right (Result v)))
        | Just (MmapFile f) <- parseMaybe parseJSON v = do
                cts <- runExceptT (fmap L.fromStrict (readMapFile f))
                case cts of
                        Left _ -> return $ responseError $ ResponseError "can't read map view of file" f
                        Right r' -> case eitherDecode r' of
                                Left e' -> return $ responseError $ ResponseError ("can't parse response: {}" ~~ e') (fromUtf8 r')
                                Right r'' -> return r''
#endif
unMmap r = return r

makeSocket :: ConnectionPort -> IO Socket
makeSocket (NetworkPort _) = socket AF_INET Stream defaultProtocol
makeSocket (UnixPort _) = socket AF_UNIX Stream defaultProtocol

sockAddr :: ConnectionPort -> HostAddress -> SockAddr
sockAddr (NetworkPort p) addr = SockAddrInet (fromIntegral p) addr
sockAddr (UnixPort s) _ = SockAddrUnix s

unlink :: ConnectionPort -> IO ()
unlink (NetworkPort _) = return ()
#if mingw32_HOST_OS
unlink (UnixPort _) = return ()
#else
unlink (UnixPort s) = removeLink s
#endif