content: {-# OPTIONS_GHC -Wwarn #-} -- I anticipate rewriting this
  
  module Database.Siege.Commands where
  
  import Prelude hiding (null)
  import Data.Nullable
  
  import qualified Data.ByteString as B
  import Control.Monad.State
  import qualified Data.Enumerator as E
  
  import Database.Siege.Connection
  import Database.Siege.DBOperation
  import Database.Siege.DBNode (Ref, Node)
  import Database.Siege.StringHelper
  
  import Debug.Trace.Monad
  
  data Reply =
    ErrorReply String |
    StatusReply String |
    IntegerReply Int |
    BulkReply (Maybe String) |
    MultiReply (Maybe [Reply]) deriving Show
  
  globMatch "*" _ = True
  globMatch "" "" = True
  globMatch "" _ = False
  globMatch _ "" = False
  globMatch pattern@('*':p:ps) (m:ms) =
    if p == m then
      globMatch ps ms
    else
      globMatch pattern ms
  globMatch (p:ps) (m:ms) =
    if p == m then
      globMatch ps ms
    else
      False
  
  readCommand :: String -> [B.ByteString] -> Maybe (Maybe r -> DBOperation r Reply)
  readCommand "type" [key] = Just (\head -> do
    ref <- mapLookup head key
    ty <- getType ref
    return $ BulkReply $ fmap show ty)
  readCommand "get" [key] = Just (\head -> do
    ref <- mapLookup head key
    val <- getValue ref
    return $ BulkReply $ fmap bToSt val)
  readCommand "keys" [pattern] = Just (\head -> do
    items <- mapItems head
      (let op = do
            items <- E.continue return
            case items of
              E.EOF ->
                E.yield [] E.EOF
              E.Chunks items' -> do
                let items''' = filter (globMatch (bToSt pattern) . bToSt) $ map fst items'
                items'' <- op
                return $ items''' ++ items'' in
                  op)
    return $ MultiReply $ Just $ map (BulkReply . Just) (map bToSt items))
  readCommand "hkeys" [key, pattern] = Just (\head -> do
    ref <- mapLookup head key
    items <- mapItems ref
      (let op = do
            items <- E.continue return
            case items of
              E.EOF ->
                E.yield [] E.EOF
              E.Chunks items' -> do
                let items''' = filter (globMatch (bToSt pattern) . bToSt) $ map fst items'
                items'' <- op
                return $ items''' ++ items'' in
                  op)
    return $ MultiReply $ Just $ map (BulkReply . Just) (map bToSt items))
  readCommand "hgetall" [key] = Just (\head -> do
    ref <- mapLookup head key
    items <- mapItems ref
      (let op = do
            items <- E.continue return
            case items of
              E.EOF ->
                E.yield [] E.EOF
              E.Chunks items' -> do
                items''' <- mapM (\(key, value) -> do
                  value' <- lift $ getValue (Just value)
                  case value' of
                    Just v ->
                      return [key, v]
                    Nothing ->
                      return []) items'
                items'' <- op
                return $ (concat items''') ++ items'' in
                  op)
    return $ MultiReply $ Just $ map (BulkReply . Just) (map bToSt items))
  readCommand "hget" [key, field] = Just (\head -> do
    ref <- mapLookup head key
    ref' <- mapLookup ref field
    val <- getValue ref'
    return $ BulkReply $ fmap bToSt val)
  readCommand "hexists" [key, field] = Just (\head -> do
    ref <- mapLookup head key
    exists <- mapHas ref field
    return $ IntegerReply (if exists then 1 else 0))
  readCommand "sismember" [key, field] = Just (\head -> do
    ref <- mapLookup head key
    exists <- setHas ref field
    return $ IntegerReply (if exists then 1 else 0))
  readCommand "smembers" [key] = Just (\head -> do
    r <- mapLookup head key
    items <- setItems r
      (let op = do
            keys <- E.continue return
            case keys of
              E.EOF ->
                E.yield [] E.EOF
              E.Chunks keys' -> do
                keys'' <- op
                return $ keys' ++ keys'' in
                  op)
    return $ MultiReply $ Just $ map (BulkReply . Just) (map bToSt items))
  readCommand "scard" [key] = Just (\head -> do
    r <- mapLookup head key
    n <- setItems r
      (let op = do
            keys <- E.continue return
            case keys of
              E.EOF ->
                E.yield 0 E.EOF
              E.Chunks keys' -> do
                l <- op
                return $ l + (length keys') in
                  op)
    return $ IntegerReply n)
  readCommand _ _ = Nothing
  
  writeCommand :: String -> [B.ByteString] -> Maybe (Maybe r -> DBOperation r (Reply, Maybe r))
  writeCommand "set" [key, val] = Just (\head -> do
    val' <- createValue val
    head' <- mapInsert head key val'
    return (StatusReply "OK", head'))
  --writeCommand "incr" [key] = Just (\head -> do
  --  writeCommand "incrby" [key, "1"])
  --writeCommand "decr" [key] = Just (\head -> do
  --  writeCommand "incrby" [key, "-1"])
  --writeCommand "incrby" [key] = Just (\head -> do
  --  undefined)
  writeCommand "del" [key] = Just (\head -> do
    head' <- mapDelete head key
    return (StatusReply "OK", head'))
  writeCommand "hset" [key, field, value] = Just (\head -> do
    value' <- createValue value
    ref <- mapLookup head key
    ref' <- mapInsert ref field value'
    head' <- mapInsert head key ref'
    return (StatusReply "OK", head'))
  writeCommand "hdel" [key, field] = Just (\head -> do
    ref <- mapLookup head key
    ref' <- mapDelete ref field
    head' <- mapInsert head key ref'
    return (StatusReply "OK", head'))
  writeCommand "sadd" [key, field] = Just (\head -> do
    ref <- mapLookup head key
    ref' <- setInsert ref field
    head' <- mapInsert head key ref'
    return (StatusReply "OK", head'))
  writeCommand "srem" [key, field] = Just (\head -> do
    ref <- mapLookup head key
    ref' <- setDelete ref field
    head' <- mapInsert head key ref'
    return (StatusReply "OK", head'))
  writeCommand _ _ = Nothing
  
  command c0 c1 =
    case (readCommand c0 c1, writeCommand c0 c1) of
      (Just c, _) -> Just (Left c)
      (_, Just c) -> Just (Right c)
      _ -> Nothing
  
  commandToState :: Either (r -> DBOperation r Reply) (r -> DBOperation r (Reply, r)) -> StateT r (DBOperation r) Reply
  commandToState (Right c) = StateT c
  commandToState (Left c) = do
    head <- get
    lift $ c head
  
  sendReply :: Monad m => Reply -> ConnectionT m ()
  sendReply (ErrorReply e) = send $ B.concat $ map stToB ["-", e, "\r\n"]
  sendReply (StatusReply s) = send $ B.concat $ map stToB ["+", s, "\r\n"]
  sendReply (IntegerReply n) = send $ B.concat $ map stToB [":", show n, "\r\n"]
  sendReply (BulkReply Nothing) = send $ stToB "$-1\r\n"
  sendReply (BulkReply (Just s)) = send $ B.concat $ map stToB ["$", show $ length s, "\r\n", s, "\r\n"]
  sendReply (MultiReply (Nothing)) = send $ stToB "*-1\r\n"
  sendReply (MultiReply (Just s)) = do
    send $ B.concat $ map stToB ["*", show $ length s, "\r\n"]
    mapM_ sendReply s
  