{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NamedFieldPuns    #-}

module Festung.FrontendSpec (spec) where

import           Control.Monad
import           Data.Aeson
import qualified Data.ByteString.Lazy as B
import qualified Data.ByteString as BS
import qualified Data.ByteString.Base64 as B64
import qualified Data.ByteString.Char8 as BS8
import           Data.Int
import           Data.List
import           Data.Text.Encoding                (encodeUtf8)
import qualified Data.Text as T
import qualified Data.Scientific as S
import           Data.Semigroup                    ((<>))
import           Data.Word
import qualified Network.Wai.Test as W
import           System.Directory
import           System.FilePath                   ((</>))
import           System.IO                         (writeFile)
import           Test.Hspec
import           Test.HUnit                        (assertFailure)
import           Yesod                             (liftIO, Yesod)
import           Yesod.Test

import           Festung.Config
import           Festung.Frontend
import           Festung.Utils                     (getVersion)
import           Festung.Vault.VaultManager        (newManager)
import qualified Festung.Vault.Persistence as P

import           TestUtils


type VaultList = [String]

newtype SimpleQuery = SimpleQuery String


instance ToJSON SimpleQuery where
    toJSON     (SimpleQuery q) = object ["sql" .= q]
    toEncoding (SimpleQuery q) = pairs ("sql" .= q)


data ResultValue = RString String
                 | RFloat  Double
                 | RInt    Int64
                 | RBlob   [Word8]
                 | RNull
                 deriving (Eq, Show)


instance FromJSON ResultValue where
    parseJSON (Number n) = return $ convert n
        where convert = either RFloat RInt . S.floatingOrInteger
    parseJSON (String s) = return $ convert s
        where convert = RString . T.unpack
    parseJSON Null       = return RNull
    parseJSON _          = fail "Could not parse the ResultValue"


instance ToJSON ResultValue where
    toJSON (RString s) = String (T.pack s)
    toJSON (RFloat  f) = Number (S.fromFloatDigits f)
    toJSON (RInt    i) = Number (S.scientific (fromIntegral i) 0)
    toJSON RNull       = Null


type ResultRow   = [ResultValue]
type HeaderType  = String -- This should be an enum
type HeaderName  = String
data Header      = Header
    { headerType :: HeaderType
    , headerName :: HeaderName
    } deriving (Eq, Show)


instance FromJSON Header where
    parseJSON = withObject "Expects an object" $ \r ->
        Header         <$>
        r .: "type"    <*>
        r .: "name"


data Results = Results
    { rows        :: [ResultRow]
    , headers     :: [Header]
    , lastRowId   :: Int
    , rowsChanged :: Int
    } deriving (Eq, Show)


instance FromJSON Results where
    parseJSON = withObject "Results" $ \ r ->
        Results             <$>
        r .: "data"         <*>
        r .: "headers"      <*>
        r .: "last_row_id"  <*>
        r .: "rows_changed"


data ErrorObject = ErrorObject { type_ :: T.Text, description :: T.Text }


instance FromJSON ErrorObject where
    parseJSON = withObject "error root" $ \r -> do
        err <- r .: "error"
        ErrorObject <$> err .: "type" <*> err .: "description"


data ParametrizedQuery = ParametrizedQuery String [ResultValue]

instance ToJSON ParametrizedQuery where
    toJSON     (ParametrizedQuery sql params) = object [ "sql"    .= sql
                                                       , "params" .= params
                                                       ]
    toEncoding (ParametrizedQuery sql params) = pairs ("sql" .= sql <> "params" .= params)


newtype Version = Version String deriving (Eq, Show)

instance FromJSON Version where
    parseJSON = withObject "Version" $ \r ->
        Version <$> r .: "version"


createCleanDirectory :: FilePath -> IO ()
createCleanDirectory dir = do
    exists <- doesDirectoryExist dir
    when exists $ removeDirectoryRecursive dir
    createDirectory dir


withApp :: Int -> SpecWith (TestApp App) -> Spec
withApp timeout = before $ do
    -- FIXME(Antoine): Hardcoded directory
    --                 This prevents tests to run in parallel...
    let dir = "/tmp/test-festung"
    createCleanDirectory dir
    let config = Config dir timeout 0
    vaultManager <- newManager config
    return (App config vaultManager, id)


withApp_ :: SpecWith (TestApp App) -> Spec
withApp_ = withApp defaultTimeout


filterOut :: (a -> Bool) -> [a] -> [a]
filterOut p = filter (not . p)


listVaults :: YesodExample App VaultList
listVaults = do
    dir <- vaultDirectory <$> getTestYesod
    liftIO $ listDirectory dir
        where listDirectory = fmap skipDotAndDotDot . getDirectoryContents
              skipDotAndDotDot = filterOut isDotOrDotDot
              isDotOrDotDot = (`elem` [".", ".."])

simpleBody :: W.SResponse -> B.ByteString
simpleBody = W.simpleBody


failure :: String -> YesodExample site a
failure msg = liftIO (assertFailure msg) >> fail "This should never run"


getJson :: FromJSON a => YesodExample site a
getJson = withResponse $ \ req ->
    let body = simpleBody req
        unwrap (Just a) = return a
        unwrap Nothing  = failure ("Invalid json: " ++ show body)
     in unwrap $ decode body


encodePassword :: [Word8] -> BS.ByteString
encodePassword = B64.encode . BS.pack


encodeInteger :: Integer -> BS.ByteString
encodeInteger = encodeUtf8 . T.pack . show


postJson' :: (Yesod site, ToJSON a) => String -> [Word8] -> Maybe Integer -> a -> YesodExample site ()
postJson' url password kdfIter obj =
    request $ do setUrl url
                 setMethod "POST"
                 setRequestBody (encode obj)
                 addRequestHeader ("Authorization", encodePassword password)
                 case kdfIter of
                     Just n  -> addRequestHeader ("X-kdf-iter", encodeInteger n)
                     Nothing -> return ()


postJson :: (Yesod site, ToJSON a) => String -> [Word8] -> a -> YesodExample site ()
postJson url password = postJson' url password Nothing


deleteVault :: Yesod site => String -> [Word8] -> YesodExample site ()
deleteVault url password =
    request $ do setUrl url
                 setMethod "DELETE"
                 addRequestHeader ("Authorization" ,encodePassword password)


password :: [Word8]
password = [0xDE, 0xAD, 0xBE, 0xEF]


otherPassword :: [Word8]
otherPassword = [0xD0, 0x00, 0x00, 0x0D]


createTable' :: (Yesod site) => String -> [Word8] -> Maybe Integer -> YesodExample site ()
createTable' vault password kdfIter = do
    postJson' vault password kdfIter $ SimpleQuery "CREATE TABLE foo(bar int)"
    statusIs 200


createTable :: (Yesod site) => String -> [Word8] -> YesodExample site ()
createTable vault password = createTable' vault password Nothing


createTableWithData :: (Yesod site) => String -> [Word8] -> YesodExample site ()
createTableWithData vault password = do
    createTable vault password
    postJson vault password $ SimpleQuery "INSERT INTO foo(bar) VALUES (1), (2)"
    statusIs 200
    res <- getJson
    assertEq "data is returned" res
        Results { rows        = []
                , headers     = []
                , lastRowId   = 2
                , rowsChanged = 2
                }

hasVersionHeader :: (Yesod site) => YesodExample site ()
hasVersionHeader = assertHeader "X-Version" $ BS8.pack getVersion


spec :: Spec
spec = withApp_ $ do
    describe "/" $ do
        let get' = get ("/" :: String) >> statusIs 200
        it "Lists the vaults" $ do
            get'
            res <- getJson
            assertEq "No vault" res ([] :: [String])

            directory <- vaultDirectory <$> getTestYesod
            liftIO $ writeFile (directory </> "foo.sqlcipher") ""

            get'
            res <- getJson
            assertEq "One foo vault" res (["foo"] :: [String])
            hasVersionHeader

    describe "GET /version" $
        it "Returns the current version" $ do
            get ("/version" :: String)
            statusIs 200
            res <- getJson
            assertEq "Version info" res (Version getVersion)
            hasVersionHeader

    describe "Error object" $ do
        it "Returns an error object on 404" $ do
            get ("/inexistent/resounce/id" :: String)
            statusIs 404
            ErrorObject{type_} <- getJson
            assertEq "Type is 'interface_error'" type_ "interface_error"
            hasVersionHeader

        it "Returns an error object on 403" $ do
            createTable "/vault" password
            postJson' "/vault" otherPassword Nothing $ SimpleQuery "SELECT * FROM foo"
            ErrorObject{type_} <- getJson
            assertEq "Type is 'interface_error'" type_ "interface_error"
            statusIs 403

        it "Returns an error object on 400" $ do
            createTable "/vault" password
            postJson' "/vault" password Nothing $ object []
            ErrorObject{type_} <- getJson
            assertEq "Type is 'interface_error'" type_ "interface_error"
            statusIs 400

        it "Returns an operational error" $ do
            createTable "/vault" password
            postJson' "/vault" password Nothing $ SimpleQuery "SELECT baz FROM foo"
            ErrorObject{type_, description } <- getJson
            assertEq "Type is 'operational_error" type_ "operational_error"
            assertEq "Description mentions unkown column" description "no such column: baz"
            statusIs 400

    describe "POST /vault" $ do
        it "Creates the vault" $ do
            createTable "/vault" password
            res <- getJson
            assertEq "Empty results" res Results { rows = [], headers = [], lastRowId = 0 , rowsChanged = 0 }

            vaults <- listVaults
            assertEq "One vault" vaults ["vault.sqlcipher"]
            hasVersionHeader

        it "Checks the KDF iter for opened vaults" $ do
            createTable' "/vault" password (Just 4000)
            postJson' "/vault" password (Just 5000) $ SimpleQuery "SELECT 1"
            ErrorObject{type_} <- getJson
            assertEq "Type is 'interface_error'" type_ "interface_error"
            statusIs 403

        it "Opens the vault with the right KDF iter" $ do
            directory <- vaultDirectory <$> getTestYesod
            let vaultName = directory </> "foo.sqlcipher"
            liftIO $ do
                Right vault <- P.openVault' vaultName password  P.VaultParameters { P.kdfIter = Just 5 }
                _ <- P.executeQuery vault "CREATE TABLE foo (a int)"
                P.closeVault vault
            postJson' "/foo" password (Just 500) $ SimpleQuery "SELECT a FROM foo"
            ErrorObject{type_} <- getJson
            assertEq "Type is 'interface_error'" type_ "interface_error"
            statusIs 403

        it "Opens the vault with the right password" $ do
            directory <- vaultDirectory <$> getTestYesod
            let vaultName = directory </> "foo.sqlcipher"
            liftIO $ do
                Right vault <- P.openVault vaultName password
                _ <- P.executeQuery vault "CREATE TABLE foo (a int)"
                P.closeVault vault
            postJson "/foo" otherPassword $ SimpleQuery "SELECT a FROM foo"
            ErrorObject{type_} <- getJson
            assertEq "Type is 'interface_error'" type_ "interface_error"
            statusIs 403

        it "Persists data" $ do
            createTableWithData "/vault" password
            postJson "/vault" password $ SimpleQuery "SELECT bar FROM foo ORDER BY 1"
            statusIs 200
            res <- getJson
            assertEq "data is returned" res
                Results { rows        = [ [RInt 1]
                                        , [RInt 2]
                                        ]
                        , headers     = [Header "int" "bar"]
                        , lastRowId   = 2
                        , rowsChanged = -1
                        }

        it "Checks password" $ do
            createTableWithData "/vault" password
            postJson "/vault" otherPassword $ SimpleQuery "SELECT bar FROM foo"
            statusIs 403

        it "Binds parameters" $ do
            createTableWithData "/vault" password
            postJson "/vault" password $ ParametrizedQuery "INSERT INTO foo(bar) VALUES (?)" [RNull]
            statusIs 200
            postJson "/vault" password $ SimpleQuery "SELECT bar FROM foo ORDER BY 1"
            res <- getJson
            assertEq "data is returned" res
                Results { rows        = [ [RNull]
                                        , [RInt 1]
                                        , [RInt 2]
                                        ]
                        , headers     = [Header "int" "bar"]
                        , lastRowId   = 3
                        , rowsChanged = -1
                        }

        it "Handles many vaults" $ do
            createTableWithData "/a" password
            createTableWithData "/b" otherPassword
            createTableWithData "/c" password

            vaults <- listVaults
            assertEq "Three vaults" (sort vaults)
                ["a.sqlcipher", "b.sqlcipher", "c.sqlcipher"]

            postJson "/a" otherPassword $ SimpleQuery "SELECT * FROM foo"
            statusIs 403

            postJson "/b" password $ SimpleQuery "SELECT * FROM foo"
            statusIs 403

            postJson "/a" password $ SimpleQuery "INSERT INTO foo(bar) VALUES (NULL)"
            statusIs 200

            postJson "/c" password $ SimpleQuery "SELECT bar FROM foo ORDER BY 1"
            res <- getJson
            assertEq "data is returned" res
                Results { rows        = [ [RInt 1]
                                        , [RInt 2]
                                        ]
                        , headers     = [Header "int" "bar"]
                        , lastRowId   = 2
                        , rowsChanged = -1
                        }

    describe "DELETE /vault" $ do

        it "Deletes vaults" $ do
            createTableWithData "/vault" password
            deleteVault "/vault" password
            statusIs 204
            vaults <- listVaults
            assertEq "One vault" vaults []
            postJson "/vault" password $ SimpleQuery
                "SELECT count(*) AS n_table FROM sqlite_master"
            statusIs 200
            res <- getJson
            assertEq "data is returned" res
                Results { rows        = [[RInt 0]] -- 0 for no table
                        , headers     = [Header "dynamic" "n_table"]
                        , lastRowId   = 0
                        , rowsChanged = -1
                        }

        it "Doesn't delete vaults with the wrong password" $ do
            createTableWithData "/vault" password
            deleteVault "/vault" otherPassword
            statusIs 403