{-# LANGUAGE DeriveGeneric #-}

module Server
(
  run,
  sendCommit
)
where

import Network.Socket hiding (send, sendTo, recv, recvFrom)
import Network.Socket.ByteString.Lazy
import qualified Data.ByteString.Lazy as BSL
import qualified Data.ByteString as BS
import Control.Concurrent
import Control.Monad.Fix (fix)
import Control.Monad (when, forM_)
import Control.Exception (throw, try, SomeException)

import Data.Aeson
import Data.Word
import Data.List (isPrefixOf, (\\), sort)
import Data.Either (isLeft)
import System.Directory (doesFileExist, removeFile)
import System.IO (writeFile, readFile)
import GHC.Generics

import Commit
import App hiding (Commit, Action)
import Error
import Config

import Crypto.PubKey.RSA
import Crypto.Hash.Algorithms
import Crypto.PubKey.RSA.PKCS15 (signSafer, verify)

data Msg = Msg {
  act :: Action,
  actS :: String, -- Signed Action, readable as a ByteString
  pseudo :: String, -- Unique string for indetification
  pubKey :: String --A PublicKey
} deriving (Generic,Show, Read)

instance FromJSON Msg
instance ToJSON Msg

run :: App -> (App -> Commit -> IO ()) -> IO ()
run app pull =
  do  isProjectFolder
      stopIfStarted
      writeFile ".det/logs/start" $ port . flags $ app
      version <- head . lines <$> readFile ".det/HEAD"
      addrs <- getClusterAddrs
      msg <- getSignedMsg $ Pull version ("127.0.0.1:" ++ (port . flags $ app))
      forM_ addrs $ \addr ->
        do  tried <-  try $ getSock (fst addr) (snd addr)
                      :: IO (Either SomeException Socket)
            case tried of
              Left e -> putErr $ show e
              Right sock -> do
                send sock $ encode msg
                putStrLn $ "Pulling from " ++ (fst addr) ++ ":" ++ (snd addr)

      err <- try $ runServer app pull :: IO (Either SomeException ())

      case err of
        Left e ->
          do  putErr . show $ e
        _      -> return ()

      removeFile ".det/logs/start"

getSignedMsg :: Action -> IO Msg
getSignedMsg a = do
  (pubKey,privKey) <- getKeys
  msg <- signSafer (Just SHA512) privKey $ BSL.toStrict $ encode a-- Pull version
  pseudo <- getPseudo
  case msg of
    Left e -> do
      putErr $ show e
      fail $ show e
    Right msg' -> return $ Msg a (show msg') pseudo (show pubKey)

-- | Get as arg a pulltion to be run when
runServer :: App -> (App -> Commit -> IO ()) -> IO ()
runServer app pull = do
  putStrLn "Starting local server"
  putStrLn "Press ^C to quit"
  when (verbose . flags $ app) $ putStrLn "Connecting"
  let hints = defaultHints { addrFlags = [AI_NUMERICHOST, AI_NUMERICSERV], addrSocketType = Stream }
  addr:_ <- getAddrInfo (Just hints) (Just "127.0.0.1") (Just . port . flags $ app)
  sock@(MkSocket _ fam stype _ _) <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)
  bind sock (addrAddress addr)
  listen sock 1
  mainLoop app (pull app) sock 0

mainLoop :: App -> (Commit -> IO ()) -> Socket -> Int -> IO() -- Loop for listen new conn
mainLoop app pull sock me = do
  (newSock,addr) <- accept sock
  putStrLn $ "Accepting connection " ++ (show addr)
  reader <- forkIO $ runConn pull newSock
  mainLoop app pull sock me

runConn :: (Commit -> IO ()) -> Socket -> IO ()
runConn pull sock = do
  msg <- recv sock 4096
  name <- getPeerName sock
  when (not $ BSL.null msg) $
     case (decode msg):: Maybe Msg of
      Nothing -> do
        putStrLn $ "Error in message receveid: " ++ (show msg)
      Just a -> do
        putStrLn $ "Connected with " ++ (pseudo a)
        k <- getPubKeyOf (pseudo a)
        pbk <- case k of
          Nothing -> do
            rule <- getCryptoRule
            case rule of
              AcceptAnything -> assignPubKeyTo ((read $ pubKey a) :: PublicKey) (pseudo a) >>= return . Just
              AskForNewKey -> do
                putStrLn $ "New key arrived for user: " ++ (pseudo a)
                rep <- fix $ \loop -> do
                  putStrLn "Accept it ?  (y/n)"
                  line <- getLine
                  case line of
                    "y" -> return True
                    "n" -> return False
                    otherwise -> loop
                if rep
                  then putStrLn "Accepting key..." >> assignPubKeyTo ((read $ pubKey a) :: PublicKey) (pseudo a) >>= return . Just
                  else putStrLn "Refusing key..." >> return Nothing
              RefuseUnknownUser -> putStrLn "Refusing key..." >> return Nothing
          Just b -> return $ Just b
        if not (betterverify pbk a)
          then putErr "Wrongly signed message"
          else case (act a) of
            Push commits -> useNewCommit pull commits sock
            Pull v addr -> do
              version <- head . lines <$> readFile ".det/HEAD"
              case compare v version of
                GT -> do
                  port <- head . lines <$> readFile ".det/logs/start"
                  msg <- getSignedMsg $ Pull version ("127.0.0.1:" ++ port)
                  sendMessageTo msg (parseAddr addr)
                LT -> do
                  let ver = read v :: Int
                  commits <- filter (\c -> ident c > ver)
                            <$> getAllLocalCommits
                  msg <- getSignedMsg $ Push commits
                  sendMessageTo msg (parseAddr addr)
                EQ -> putStrLn "Same versions !"
  putStrLn $ "Connection closed:" ++ (show name)
  close sock
  return ()
  where
    betterverify pbk' a = case pbk' of
      Nothing -> False
      Just pbk -> verify (Just SHA512) pbk (BSL.toStrict $ encode $ act a) (read (actS a) :: BS.ByteString)

useNewCommit :: (Commit -> IO ()) -> [Commit] -> Socket -> IO ()
useNewCommit pull commits sock = do
  com <- getAllLocalCommits
  let cs = commits \\ com
  forM_ (sort cs) $ \c -> do
    pul <- try (pull c) :: IO (Either PullE ())
    either (putErr . show) return pul
  when (not . null $ cs) $ sendCommit commits

-- Send commit to our server
sendCommit :: [Commit] -> IO ()
sendCommit msg = do
  addrs <- getClusterAddrs
  when (null addrs) $ putStrLn "Empty cluster"
  msg' <- getSignedMsg $ Push msg
  forM_ addrs $ sendMessageTo msg'

sendMessageTo :: Msg -> (String, String) -> IO ()
sendMessageTo msg addr =
  do  tried <-  try $ getSock (fst addr) (snd addr)
                :: IO (Either SomeException Socket)
      case tried of
        Left e -> putErr (show e)
        Right sock -> do
          send sock $ encode msg
          putStrLn $ "Message sent to " ++ (fst addr) ++ ":" ++ (snd addr)

getSock :: String -> String -> IO Socket
getSock ip port = do
  let hints = defaultHints { addrFlags = [AI_NUMERICHOST, AI_NUMERICSERV], addrSocketType = Stream }
  addr:_ <- getAddrInfo (Just hints) (Just "127.0.0.1") Nothing
  sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)
  addr':_ <- getAddrInfo (Just hints) (Just ip) (Just port)
  con <-  try $ connect sock $ addrAddress addr'
          :: IO (Either SomeException ())
  when (isLeft con) $ throw $ CanNotConnect (ip, port)
  return sock
