{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE RankNTypes #-}
module Database.PostgreSQL.Simple.Data where

import Blaze.ByteString.Builder
import Control.Exception
import Control.Monad
import Control.Monad.State
import Data.ByteString.UTF8 (fromString)
import Data.Char
import Data.Data
import Data.List
import Data.Maybe
import System.IO.Unsafe
import Database.PostgreSQL.Simple.ToField
import Prelude hiding (catch)

-- | The type used for encoding fields of a data type into an SQL
-- expression.
data Fields = Fields [String]
  deriving Show

-- | The type used for encoding the values of fields of a record type
-- into an SQL expression.
newtype Values = Values [Action]
  deriving Show

-- | Type used for encoding data type names as database entities.
newtype Name = Name String
  deriving Show

-- | This will encode, e.g. Foo { bar :: String, mu :: Int } to
-- bar,mu.
instance ToField Fields where
  toField (Fields fields) =
    Plain . buildString . intercalate "," $ map normalize fields

-- | This will encode, e.g. Foo { bar :: String, mu :: Int } to
-- bar,mu.
instance ToField Values where
  toField (Values actions) = Many (zipWith encode [0::Int ..] actions) where
    encode 0 value = toField value
    encode _ action = Many [Plain (buildString ","),toField action]

instance ToField Name where
  toField (Name i) = Plain (buildString i)

-- | Because stupid APIs.
buildString :: String -> Builder
buildString = fromWrite . writeByteString . fromString

-- | Generate a Fields representation of a data type, ready for
-- passing to a query/exec function.
dataInsertFields :: Data a => a -> Fields
dataInsertFields a = withConstructor a $ \cons -> Fields (constrFields cons)

-- | Generate a Fields representation of a data type, ready for
-- passing to a query/exec function.
dataInsertFieldsSans :: Data a => [String] -> a -> Fields
dataInsertFieldsSans sans a = withConstructor a $ \cons ->
  Fields (filter (not . flip elem sans) (constrFields cons))

-- | Generate a Fields representation of a data type, ready for
-- passing to a query/exec function.
dataSelectFields :: Data a => a -> Fields
dataSelectFields a = withConstructor a $ \cons -> Fields (constrFields cons)

-- | Generate the code for values.
dataValues :: Data a => a -> Values
dataValues a = withConstructor a $ \_ -> Values $ gmapQ convertValue a

-- | Generate the code for values, filtering on the given fields.
dataValuesSans :: Data a => [String] -> a -> Values
dataValuesSans sans a = withConstructor a $ \cons ->
  let fields = constrFields cons
      values = map snd (filter (not . flip elem sans . fst) (zip fields (gmapQ convertValue a)))
  in Values values

-- | Generate an entity name for a data type.
dataName :: Data a => a -> Name
dataName a = withConstructor a $ \cons -> Name (drop 1 (normalize (show cons)))

-- | Convert a value to an SQL-rendering action.
convertValue :: (forall d. Data d => d -> Action)
convertValue d =
  fromMaybe (error $ "Unable to convert value of type: " ++
                     show (dataTypeOf d))
            (foldr mplus
                   mzero
                   [go (ty :: Int)
                   ,go (ty :: Integer)
                   ,go (ty :: Double)
                   ,go (ty :: String)
                   ,go (ty :: Bool)
                   ,go (ty :: Maybe Int)
                   ,go (ty :: Maybe Integer)
                   ,go (ty :: Maybe Double)
                   ,go (ty :: Maybe String)
                   ,go (ty :: Maybe Bool)
                   ])

  where ty :: a
        ty = undefined

        go :: (Typeable f,ToField f) => f -> Maybe Action
        go = convert d

-- | Convert to a specific type.
convert :: (Data d,Typeable f,ToField f) => d -> f -> Maybe Action
convert d typ =
  case cast d of
    Nothing -> Nothing
    Just d' -> Just (toField (fst (d', [d',typ])))

-- | With an appropriate connector.
withConstructor :: Data a => a -> (Constr -> t) -> t
withConstructor a f =
  case dataTypeConstrs (dataTypeOf a) of
    []      -> error $ "No constructors for data type: " ++
                       show (dataTypeOf a)
    (_:_:_) -> error $ "Too many constructors for data type: " ++
                       show (dataTypeOf a)
    [cons]  -> case constrFields cons of
      []    -> error $ "Must be a record, but isn't: " ++
                       show (dataTypeOf a)
      _     -> f cons

-- | Normalize a Haskell name to an SQL name.
normalize :: [Char] -> [Char]
normalize = concatMap replace where
  replace c | isUpper c = "_" ++ [toLower c]
            | otherwise = [c]

newtype FieldName = FieldName String
  deriving (Typeable,Data,Show)
instance Exception FieldName

-- | Get a data type consisting of "described" fields.
dataDescribeFields :: Data a => a
dataDescribeFields = result where
  result = withConstructor result $ \cons ->
    evalState (fromConstrM (do fieldName:fields <- get
                               put fields
                               return (throw (FieldName fieldName)))
                           cons)
              (constrFields cons)

-- | Get the a record field.
dataField :: Data a => (a -> b) -> String
dataField f = unsafePerformIO $
  catch (let !_ = f dataDescribeFields in undefined)
        (\(FieldName name) -> return name)

--------------------------------------------------------------------------------
-- Experimental SQL interface

data Where a where
  (:=:) :: (Eq a,Eq b) => Where a -> Where b -> Where Bool
  And :: Where Bool -> Where Bool -> Where Bool
  Field :: (Field a) -> Where a
  Int :: Int -> Where Int
  Double :: Double -> Where Double
  String :: String -> Where String
  TRUE :: Where Bool
  FALSE :: Where Bool

data Field b = F String

data Submission =
  Submission { submissionId :: Int, submissionTitle :: String }
  deriving (Data,Typeable)

data Order = Desc String | Asc String

-- | Render a WHERE condition to a string.
whereToString :: Where a -> String
whereToString w = case w of
  String string -> "E'" ++ init (tail (show string)) ++ "'"
  Double i -> show i
  Int i -> show i
  a :=: b -> "(" ++ whereToString a ++ " = " ++ whereToString b ++ ")"
  And a b -> "(" ++ whereToString a ++ " AND " ++ whereToString b ++ ")"
  Field (F str) -> "\"" ++ normalize str ++ "\""
  TRUE -> "TRUE"
  FALSE -> "FALSE"

-- | Make a field expression.
field :: Data a => (a -> b) -> Where b
field f = Field (F (dataField f))

-- | Make a field expression.
desc :: Data a => (a -> b) -> Order
desc f = Desc (dataField f)

-- | Make a field expression.
asc :: Data a => (a -> b) -> Order
asc f = Asc (dataField f)

-- | Run a query.
query :: (Sql.ToRow q, Sql.FromRow r) => Sql.Query -> q -> Transaction [r]
query qry args = do
  conn <- ask
  liftIO $ Sql.query conn qry args

-- | Execute a query.
exec :: (Sql.ToRow q) => Sql.Query -> q -> Transaction Int64
exec qry args = do
  conn <- ask
  liftIO $ Sql.execute conn qry args

-- | Insert a data value entirely.
insert :: Data a => a -> Transaction Int64
insert d =
  exec "INSERT INTO ? (?) VALUES (?)"
       (dataName d
       ,dataInsertFields d
       ,dataValues d)

-- | Insert a value sans some fields.
insertSans :: Data a => [String] -> a -> Transaction Int64
insertSans sans d =
  exec "INSERT INTO ? (?) VALUES (?)"
       (dataName d
       ,dataInsertFieldsSans sans d
       ,dataValuesSans sans d)

-- | Select with a DSL query.
select :: (Data a,Sql.FromRow r) => a -> [Where Bool] -> [Order] -> Transaction [r]
select a w orders =
  query (fromString ("SELECT ? FROM ? WHERE " ++ whereToString (foldr And TRUE w) ++ showOrders orders))
        (dataSelectFields a,dataName a)

showOrders orders =
  case orders of
    [] -> ""
    orders' -> " ORDER BY " ++ (intercalate "," (map showOrdering orders'))

  where showOrdering (Desc e) = normalize e ++ " DESC"
        showOrdering (Asc e) = normalize e ++ " ASC"

{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE OverloadedStrings #-}

-- | The server.

module Server where

import Server.API
import Server.Migration
import SharedTypes

import Data.Maybe
import Database.PostgreSQL.Simple.Data
import Snap.Core
import Snap.Http.Server
import System.Environment

-- | Main entry point.
server :: IO ()
server = do
  args <- getArgs
  migrate (any (=="-create-version") args)
  httpServe (setPort 10002 defaultConfig) (route [("/json",handle dispatcher)])

-- | Dispatch on the commands.
dispatcher :: Command -> Dispatcher
dispatcher cmd =
  case cmd of
    NewTask task r -> r <~ do
      _ <- transaction $ insertSans [dataField taskId] task
      return OK
    Tasks r -> r <~ do
      fmap List $ transaction $ do
        returns $ \a -> do
          tasks <- select a [] [desc taskId]
          return (map (\(id,title,difficulty,tags,background,what,gohere) ->
                        Task id title difficulty tags background what gohere)
                      tasks)
    GetTask id r -> r <~ do
      transaction $ do
        returns $ \a -> do
          tasks <- select a [field taskId :=: Int id] []
          return (listToMaybe (map (\(id,title,difficulty,tags,background,what,gohere) ->
                                     Task id title difficulty tags background what gohere)
                                   tasks))

data Task = Task { taskId             :: Int
                 , taskTitle          :: String
                 , taskDifficulty     :: String
                 , taskTags           :: String
                 , taskBackground     :: String
                 , taskWhatNeedsDoing :: String
                 , taskGoHere         :: String
                 }
  deriving (Show,Data,Typeable)