{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleInstances #-}

module Main where

import Data.Char
import Data.Word
import qualified Data.ByteString.Char8 as BS
--import Test.Framework
import Test.Framework.TH
--import Test.Framework.Providers.HUnit
import Test.Framework.Providers.QuickCheck2
import Test.QuickCheck
--import Test.QuickCheck.Arbitrary

import Network.Memcache.Class (toChunks)
import Network.Memcache.Op
import qualified Network.Memcache.Response as R

import Debug.Trace

type ValueT = BS.ByteString
type BytesT = Word64

newtype Key = Key { getKey :: BS.ByteString } deriving Show
newtype PrintableString = PrintableString { getPrintableString :: String } deriving Show

instance Arbitrary BS.ByteString where
  arbitrary = fmap BS.pack $ arbitrary `suchThat` printableNonSpace

instance Arbitrary Key where
  arbitrary = do
    bs <- fmap BS.pack $ arbitrary `suchThat` printableNonSpace
    return (Key bs)

instance Arbitrary PrintableString where
  arbitrary = do
    bs <- arbitrary `suchThat` printableNonSpace
    return (PrintableString bs)

instance Arbitrary Option where
  arbitrary = oneof [ return Noreply ]

printableNonSpace :: String -> Bool
printableNonSpace xs = not (null xs) && (and $ map (\c -> isPrint c && c /= ' ') xs)

main :: IO ()
main = $(defaultMainGenerator)

----------------------------------------------------------------

prop_toChunks_SetOp :: Key -> Word32 -> Word64 -> [Option] -> ValueT -> Bool
prop_toChunks_SetOp key flags exptime options value = r == e
 where
   key' = getKey key
   r = chunk2string (toChunks $ SetOp key' flags exptime (fromIntegral $ BS.length value) value options)
   e = "set " ++ BS.unpack key' ++ " " ++ show flags ++ " " ++ show exptime ++ " " ++ (show $ BS.length value) ++ showOptions options ++ ln ++ BS.unpack value ++ ln

prop_toChunks_CasOp :: Key -> Word32 -> Word64 -> Word64 -> [Option] -> ValueT -> Bool
prop_toChunks_CasOp key flags exptime version options value = r == e
 where
   key' = getKey key
   r = chunk2string (toChunks $ CasOp key' flags exptime (fromIntegral $ BS.length value) version value options)
   e = "cas " ++ BS.unpack key' ++ " " ++ show flags ++ " " ++ show exptime ++ " " ++ (show $ BS.length value) ++ " " ++ show version ++ showOptions options ++ ln ++ BS.unpack value ++ ln

prop_toChunks_AddOp :: Key -> Word32 -> Word64 -> [Option] -> ValueT -> Bool
prop_toChunks_AddOp key flags exptime options value = r == e
 where
   key' = getKey key
   r = chunk2string (toChunks $ AddOp key' flags exptime (fromIntegral $ BS.length value) value options)
   e = "add " ++ BS.unpack key' ++ " " ++ show flags ++ " " ++ show exptime ++ " " ++ (show $ BS.length value) ++ showOptions options ++ ln ++ BS.unpack value ++ ln

prop_toChunks_ReplaceOp :: Key -> Word32 -> Word64 -> [Option] -> ValueT -> Bool
prop_toChunks_ReplaceOp key flags exptime options value = r == e
 where
   key' = getKey key
   r = chunk2string (toChunks $ ReplaceOp key' flags exptime (fromIntegral $ BS.length value) value options)
   e = "replace " ++ BS.unpack key' ++ " " ++ show flags ++ " " ++ show exptime ++ " " ++ (show $ BS.length value) ++ showOptions options ++ ln ++ BS.unpack value ++ ln

prop_toChunks_AppendOp :: Key -> Word32 -> Word64 -> [Option] -> ValueT -> Bool
prop_toChunks_AppendOp key flags exptime options value = r == e
 where
   key' = getKey key
   r = chunk2string (toChunks $ AppendOp key' flags exptime (fromIntegral $ BS.length value) value options)
   e = "append " ++ BS.unpack key' ++ " " ++ show flags ++ " " ++ show exptime ++ " " ++ (show $ BS.length value) ++ showOptions options ++ ln ++ BS.unpack value ++ ln

prop_toChunks_PrependOp :: Key -> Word32 -> Word64 -> [Option] -> ValueT -> Bool
prop_toChunks_PrependOp key flags exptime options value = r == e
 where
   key' = getKey key
   r = chunk2string (toChunks $ PrependOp key' flags exptime (fromIntegral $ BS.length value) value options)
   e = "prepend " ++ BS.unpack key' ++ " " ++ show flags ++ " " ++ show exptime ++ " " ++ (show $ BS.length value) ++ showOptions options ++ ln ++ BS.unpack value ++ ln

prop_toChunks_GetOp :: [Key] -> Bool
prop_toChunks_GetOp keys = r == e
 where
   keys' = map getKey keys
   r = chunk2string (toChunks $ GetOp keys')
   e = "get " ++ BS.unpack (BS.intercalate " " keys') ++ ln

prop_toChunks_GetsOp :: [Key] -> Bool
prop_toChunks_GetsOp keys = r == e
 where
   keys' = map getKey keys
   r = chunk2string (toChunks $ GetsOp keys')
   e = "gets " ++ BS.unpack (BS.intercalate " " keys') ++ ln

prop_toChunks_DeleteOp :: Key -> [Option] -> Bool
prop_toChunks_DeleteOp key options = r == e
 where
   key' = getKey key
   r = chunk2string (toChunks $ DeleteOp key' options)
   e = "delete " ++ BS.unpack key' ++ showOptions options ++ ln

prop_toChunks_IncrOp :: Key -> Word64 -> [Option] -> Bool
prop_toChunks_IncrOp key diff options = r == e
 where
   key' = getKey key
   r = chunk2string (toChunks $ IncrOp key' diff options)
   e = "incr " ++ BS.unpack key' ++ " " ++ show diff ++ showOptions options ++ ln

prop_toChunks_DecrOp :: Key -> Word64 -> [Option] -> Bool
prop_toChunks_DecrOp key diff options = r == e
 where
   key' = getKey key
   r = chunk2string (toChunks $ DecrOp key' diff options)
   e = "decr " ++ BS.unpack key' ++ " " ++ show diff ++ showOptions options ++ ln

prop_toChunks_TouchOp :: Key -> Word64 -> [Option] -> Bool
prop_toChunks_TouchOp key exptime options = r == e
 where
   key' = getKey key
   r = chunk2string (toChunks $ TouchOp key' exptime options)
   e = "touch " ++ BS.unpack key' ++ " " ++ show exptime ++ showOptions options ++ ln

prop_toChunks_PingOp :: Bool
prop_toChunks_PingOp = chunk2string (toChunks PingOp) == "ping" ++ ln

prop_toChunks_FlushAllOp :: Bool
prop_toChunks_FlushAllOp = chunk2string (toChunks FlushAllOp) == "flush_all" ++ ln

prop_toChunks_QuitOp :: Bool
prop_toChunks_QuitOp = chunk2string (toChunks QuitOp) == "quit" ++ ln

prop_toChunks_StatsOp :: [PrintableString] -> Bool
prop_toChunks_StatsOp args = chunk2string (toChunks $ StatsOp (map (BS.pack . getPrintableString) args)) == "stats" ++ concat (map (\s -> " " ++ getPrintableString s) args) ++ ln

--------------------------------

prop_parseOpHeader_SetOp :: Key -> Word32 -> Word64 -> [Option] -> ValueT -> Bool
prop_parseOpHeader_SetOp key flags exptime options value = parseOpHeader_SetOp "set" SetOp key flags exptime options value

prop_parseOpHeader_CasOp :: Key -> Word32 -> Word64 -> Word64 -> [Option] -> ValueT -> Bool
prop_parseOpHeader_CasOp key flags exptime version options value = op == Just (CasOp key' flags exptime (fromIntegral $ BS.length value) version "" options)
 where
   key' = getKey key
   op = parseOpHeader (BS.pack ("cas " ++ BS.unpack key' ++ " " ++ show flags ++ " " ++ show exptime ++ " " ++ show (BS.length value) ++ " " ++ show version ++ showOptions options))

prop_parseOpHeader_AddOp :: Key -> Word32 -> Word64 -> [Option] -> ValueT -> Bool
prop_parseOpHeader_AddOp key flags exptime options value = parseOpHeader_SetOp "add" AddOp key flags exptime options value

prop_parseOpHeader_ReplaceOp :: Key -> Word32 -> Word64 -> [Option] -> ValueT -> Bool
prop_parseOpHeader_ReplaceOp key flags exptime options value = parseOpHeader_SetOp "replace" ReplaceOp key flags exptime options value

prop_parseOpHeader_AppendOp :: Key -> Word32 -> Word64 -> [Option] -> ValueT -> Bool
prop_parseOpHeader_AppendOp key flags exptime options value = parseOpHeader_SetOp "append" AppendOp key flags exptime options value

prop_parseOpHeader_PrependOp :: Key -> Word32 -> Word64 -> [Option] -> ValueT -> Bool
prop_parseOpHeader_PrependOp key flags exptime options value = parseOpHeader_SetOp "prepend" PrependOp key flags exptime options value

prop_parseOpHeader_GetOp :: [Key] -> Bool
prop_parseOpHeader_GetOp keys = op == if null keys then Nothing else Just (GetOp keys')
  where
   keys' = map getKey keys
   op = parseOpHeader (BS.pack ("get " ++ BS.unpack (BS.intercalate " " keys')))

prop_parseOpHeader_GetsOp :: [Key] -> Bool
prop_parseOpHeader_GetsOp keys = op == if null keys then Nothing else Just (GetsOp keys')
  where
   keys' = map getKey keys
   op = parseOpHeader (BS.pack ("gets " ++ BS.unpack (BS.intercalate " " keys')))

prop_parseOpHeader_DeleteOp :: Key -> [Option] -> Bool
prop_parseOpHeader_DeleteOp key options = op == Just (DeleteOp key' options)
 where
   key' = getKey key
   op = parseOpHeader (BS.pack ("delete " ++ BS.unpack key' ++ showOptions options))

prop_parseOpHeader_IncrOp :: Key -> Word64 -> [Option] -> Bool
prop_parseOpHeader_IncrOp key value options = op == Just (IncrOp key' value options)
 where
   key' = getKey key
   op = parseOpHeader (BS.pack ("incr " ++ BS.unpack key' ++ " " ++ show value ++ showOptions options))

prop_parseOpHeader_DecrOp :: Key -> Word64 -> [Option] -> Bool
prop_parseOpHeader_DecrOp key value options = op == Just (DecrOp key' value options)
 where
   key' = getKey key
   op = parseOpHeader (BS.pack ("decr " ++ BS.unpack key' ++ " " ++ show value ++ showOptions options))

prop_parseOpHeader_TouchOp :: Key -> Word64 -> [Option] -> Bool
prop_parseOpHeader_TouchOp key exptime options = op == Just (TouchOp key' exptime options)
 where
   key' = getKey key
   op = parseOpHeader (BS.pack ("touch " ++ BS.unpack key' ++ " " ++ show exptime ++ showOptions options))

prop_parseOpHeader_PingOp :: Bool
prop_parseOpHeader_PingOp = parseOpHeader "ping" == Just (PingOp)

prop_parseOpHeader_FlushAllOp :: Bool
prop_parseOpHeader_FlushAllOp = parseOpHeader "flush_all" == Just (FlushAllOp)

prop_parseOpHeader_VersionOp :: Bool
prop_parseOpHeader_VersionOp = parseOpHeader "version" == Just (VersionOp)

prop_parseOpHeader_QuitOp :: Bool
prop_parseOpHeader_QuitOp = parseOpHeader "quit" == Just (QuitOp)

prop_parseOpHeader_StatsOp :: [PrintableString] -> Bool
prop_parseOpHeader_StatsOp stats = parseOpHeader (BS.pack $ "stats" ++ concat (map (\s -> " " ++ getPrintableString s) stats)) == Just (StatsOp (map (BS.pack . getPrintableString) stats))

--------------------------------

prop_toChunks_Value :: Key -> Word32 -> ValueT -> Maybe Word64 -> Bool
prop_toChunks_Value key flag value version = chunk2string (toChunks $ R.Value key' flag len value version) == resp
  where
    len = fromIntegral $ BS.length value
    key' = getKey key
    resp = "VALUE " ++ BS.unpack key' ++ " " ++ show flag ++ " "++ show len ++ showVersion version ++ ln ++ BS.unpack value ++ ln
    showVersion version' = case version' of
      Just v -> " " ++ show v
      Nothing -> ""

prop_toChunks_Ok :: Bool
prop_toChunks_Ok = chunk2string (toChunks R.Ok) == "OK" ++ ln

--------------------------------

prop_parseResponseHeader_Value :: Key -> Word32 -> Word64 -> Maybe Word64 -> Bool
prop_parseResponseHeader_Value key flags len version = response == Just (R.Value key' flags len "" version)
  where
    response = R.parseResponseHeader input
    input = BS.pack $ "VALUE " ++ BS.unpack key' ++ " " ++ show flags ++ " " ++ show len ++ versionPart version
    key' = getKey key
    versionPart version' = case version' of
      Just v -> " " ++ show v
      Nothing -> ""

prop_parseResponseHeader_Ok :: Bool
prop_parseResponseHeader_Ok = R.parseResponseHeader "OK" == Just (R.Ok)

prop_parseResponseHeader_ServerError :: PrintableString -> Bool
prop_parseResponseHeader_ServerError msg = R.parseResponseHeader (BS.pack $ "SERVER_ERROR " ++ msg' ++ "\r\n") == Just (R.ServerError msg')
  where
    msg' = getPrintableString msg

prop_parseResponseHeader_ClientError :: PrintableString -> Bool
prop_parseResponseHeader_ClientError msg = R.parseResponseHeader (BS.pack $ "CLIENT_ERROR " ++ msg' ++ "\r\n") == Just (R.ClientError msg')
  where
    msg' = getPrintableString msg

prop_parseResponseHeader_Code :: Word64 -> Bool
prop_parseResponseHeader_Code code = R.parseResponseHeader (BS.pack $ show code) == Just (R.Code code)

----------------------------------------------------------------

chunk2string :: [BS.ByteString] -> String
chunk2string = BS.unpack . BS.concat

ln :: String
ln = "\r\n"

showOptions :: Show a => [a] -> String
showOptions options = (concat $ map (\o -> " " ++ show o) options)

parseOpHeader_SetOp :: String -> (BS.ByteString -> Word32 -> Word64 -> BytesT -> ValueT -> [Option] -> Op) -> Key -> Word32 -> Word64 -> [Option] -> ValueT -> Bool
parseOpHeader_SetOp cmd opType key flags exptime options value = if op == expected then True else trace ("expected: " ++ show expected ++ " but: " ++ show op) False
 where
   key' = getKey key
   expected = Just (opType key' flags exptime (fromIntegral $ BS.length value) "" options)
   op = parseOpHeader (BS.pack (cmd ++ " " ++ BS.unpack key' ++ " " ++ show flags ++ " " ++ show exptime ++ " " ++ show (BS.length value) ++ showOptions options))