{-# LANGUAGE OverloadedStrings #-}

module Server where

import Types

import Control.Concurrent (myThreadId)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Trans.Either (EitherT, left)
import Data.IORef (IORef, atomicModifyIORef', readIORef)
import Data.List ((\\), sortBy)
import Data.Ord (comparing)
import qualified Data.IntMap.Lazy as IM (IntMap, elems, insert, keys, lookup, member)
import Servant ((:<|>)(..), Proxy(..), Server, ServantErr, err404, errBody)


vehicleAPI :: Proxy VehicleAPI
vehicleAPI = Proxy


server :: IORef (IM.IntMap Vehicle) -> Server VehicleAPI
server ref = getAllVehicles
        :<|> getVehicleById
        :<|> postVehicle
        :<|> putVehicle
        -----
        :<|> getIssuesById
        :<|> putIssues
  where
    getAllVehicles :: EitherT ServantErr IO [Vehicle]
    getAllVehicles = do
        liftIO $ print =<< myThreadId
        IM.elems <$> liftIO (readIORef ref)

    getVehicleById :: Int -> EitherT ServantErr IO Vehicle
    getVehicleById i = maybe notFound return =<< IM.lookup i <$> liftIO (readIORef ref)

    notFound :: EitherT ServantErr IO a
    notFound = left err404 { errBody = "Vehicle ID not found." }

    postVehicle :: Vehicle -> EitherT ServantErr IO Vehicle
    postVehicle v = liftIO $ atomicModifyIORef' ref insertIntoTbl
      where
        insertIntoTbl :: IM.IntMap Vehicle -> (IM.IntMap Vehicle, Vehicle)
        insertIntoTbl tbl = let newUniqueId = head . ([0..] \\) $ IM.keys tbl
                                tbl'        = IM.insert newUniqueId v tbl
                            in (tbl', v)

    putVehicle :: Int -> Vehicle -> EitherT ServantErr IO Vehicle
    putVehicle i v = putHelper f
      where
        f :: IM.IntMap Vehicle -> (IM.IntMap Vehicle, Maybe Vehicle)
        f tbl | i `IM.member` tbl = let tbl' = IM.insert i v tbl
                                    in (tbl', Just v)
              | otherwise         = (tbl, Nothing)

    putHelper :: (IM.IntMap Vehicle -> (IM.IntMap Vehicle, Maybe a)) -> EitherT ServantErr IO a
    putHelper f = maybe notFound return =<< liftIO (atomicModifyIORef' ref f)

    -----

    getIssuesById :: Int -> Maybe SortBy -> EitherT ServantErr IO [Issue]
    getIssuesById i msb = do
        unsorted <- issues <$> getVehicleById i
        return . maybe unsorted (sortIssues unsorted) $ msb
      where
        sortIssues :: [Issue] -> SortBy -> [Issue]
        sortIssues is sb = case sb of ByType     -> sortHelper issueType is
                                      ByPriority -> sortHelper priority  is

        sortHelper :: (Ord a) => (Issue -> a) -> [Issue] -> [Issue]
        sortHelper = sortBy . comparing

    putIssues :: Int -> [Issue] -> EitherT ServantErr IO [Issue]
    putIssues i is = putHelper f
      where
        f :: IM.IntMap Vehicle -> (IM.IntMap Vehicle, Maybe [Issue])
        f tbl = maybe (tbl, Nothing) found $ IM.lookup i tbl
          where
            found :: Vehicle -> (IM.IntMap Vehicle, Maybe [Issue])
            found v = let v'   = v { issues = is }
                          tbl' = IM.insert i v' tbl
                      in (tbl', Just is)