I will be back after bbq is done

WillBeBack

{-# LANGUAGE DeriveDataTypeable, TemplateHaskell, TypeFamilies, FlexibleInstances, FlexibleContexts, InstanceSigs #-}

module Data.VCodePool where

import Data.Data               (Data, Typeable)
import Data.SafeCopy           (base, deriveSafeCopy, SafeCopy(..))

import Control.Applicative     ((<$>), (<*>))
import Control.Monad.Reader    (ask)
import Control.Monad.State     (get, put)
import Data.Acid
import Data.Acid.Advanced

import Data.IxSet
    ( Indexable, IxSet(..), ixFun, ixSet
    , empty, (@=), getOne
    )
import qualified Data.IxSet as Ix

import System.Random
import Data.Time               (formatTime)
import Data.Time.Clock         (getCurrentTime)
import System.Locale           (defaultTimeLocale)

import Data.Account

newtype ExpireTime = ExpireTime Int
  deriving (Eq, Ord, Data, Typeable, Show)
newtype VCode = VCode { unVCode :: String}
  deriving (Eq, Ord, Data, Typeable, Show)
$(deriveSafeCopy 0 'base ''ExpireTime)
$(deriveSafeCopy 0 'base ''VCode)

data Record k = Record {
    getKey    :: k
  , getVCode  :: VCode
  , getETime  :: ExpireTime
  } deriving (Eq, Ord, Data, Typeable, Show)
$(deriveSafeCopy 0 'base ''Record)

instance (Typeable k, Ord k) => Indexable (Record k) where
  empty = ixSet
    [ ixFun $ \bp -> [getKey bp]
    , ixFun $ \bp -> [getVCode bp]
    ]

type RecordPool k = IxSet (Record k)

newRecord :: (Typeable k, Ord k)
  => k -> VCode -> ExpireTime -> Update (RecordPool k) ()
newRecord key vcode etime = do
  let record = Record key vcode etime
  pool' <- Ix.updateIx key record <$> get
  put pool'

validateRecord :: (Typeable k, Ord k)
  => VCode -> ExpireTime -> Query (RecordPool k) (Maybe k)
validateRecord vcode now = do
  pool <- ask
  case getOne $ pool @= vcode of
    Nothing  -> return Nothing
    Just Record { getKey = key, getETime = etime } ->
      if etime < now
      then return Nothing
      else return $ Just key

removeRecord :: (Typeable k, Ord k)
  => VCode -> Update (RecordPool k) ()
removeRecord vcode = do
  pool' <- Ix.deleteIx vcode <$> get
  put pool'

-- Helper Functions --
getNextVCode :: IO VCode
getNextVCode = VCode . show <$> getStdRandom (randomR (100000000000000 :: Integer, 999999999999999 :: Integer))

expireIn :: ExpireTime -> IO ExpireTime
expireIn (ExpireTime ttl) = do
  now <- (read <$> formatTime defaultTimeLocale "%s" <$> getCurrentTime) :: IO Int
  return $ ExpireTime $ now + ttl

data RecordPools = RecordPools {
    getNewAccountPool :: AcidState (RecordPool Email)
  , getResetPswdPool  :: AcidState (RecordPool Email)
  , getCookiePool     :: AcidState (RecordPool AccountId)
  }

class PoolType t where
  type RecordKey t
  putRecordPool :: t -> RecordPools -> AcidState (RecordPool (RecordKey t)) -> RecordPools
  getRecordPool :: t -> RecordPools -> AcidState (RecordPool (RecordKey t))
  getRecordKey  :: t -> RecordKey t
  typePicker    :: t

newtype NewAccountEmail = NewAccountEmail Email
instance PoolType NewAccountEmail where
  type RecordKey NewAccountEmail = Email
  putRecordPool _ pools pool = pools { getNewAccountPool = pool }
  getRecordPool _ pools = getNewAccountPool pools
  getRecordKey (NewAccountEmail email) = email
  typePicker = NewAccountEmail $ Email ""

newtype ResetPswdEmail = ResetPswdEmail Email
instance PoolType ResetPswdEmail where
  type RecordKey ResetPswdEmail = Email
  putRecordPool _ pools pool = pools { getResetPswdPool = pool }
  getRecordPool _ pools = getResetPswdPool pools
  getRecordKey (ResetPswdEmail email) = email
  typePicker = ResetPswdEmail $ Email ""

newtype CookieAccountId = CookieAccountId AccountId
instance PoolType CookieAccountId where
  type RecordKey CookieAccountId = AccountId
  putRecordPool _ pools pool = pools { getCookiePool = pool }
  getRecordPool _ pools = getCookiePool pools
  getRecordKey (CookieAccountId id) = id
  typePicker = CookieAccountId $ AccountId 0

insertNewRecord
  :: (PoolType k, SafeCopy (RecordKey k), Typeable (RecordKey k))
  => RecordPools -> k -> ExpireTime -> IO VCode
insertNewRecord pools wrappedKey ttl = do
  let picker = typePicker :: k
  let pool = getRecordPool picker pools
  let key  = getRecordKey wrappedKey
  etime   <- expireIn ttl
  vcode   <- getNextVCode
  --update' pool $ NewRecord key vcode etime
  return vcode

{-
queryRecord
  :: (PoolType k, SafeCopy (RecordKey k), Typeable (RecordKey k))
  => RecordPools -> Maybe k -> VCode -> IO (Maybe (RecordKey k))
queryRecord _ pools vcode = do
  let pool = getRecordPool pools
  case getOne $ pool @= vcode of
    Nothing     -> return Nothing
    Just record -> do
      now <- expireIn $ ExpireTime 0
      if now > getETime record
      then return Nothing
      else return $ Just $ getKey record
-}

-- Template Haskell of Acid State breaks here.   --
-- Writing those types manually here.            --
-- Should use makeAcidic when this bug is fixed. --
data NewRecord k = NewRecord k VCode ExpireTime
  deriving (Typeable)
$(deriveSafeCopy 0 'base ''NewRecord)
instance (Typeable k, SafeCopy k) => Method (NewRecord k) where
  type MethodResult (NewRecord k) = ()
  type MethodState  (NewRecord k) = RecordPool k
instance (Typeable k, SafeCopy k) => UpdateEvent (NewRecord k)

data ValidateRecord k = ValidateRecord VCode ExpireTime
  deriving (Typeable)
$(deriveSafeCopy 0 'base ''ValidateRecord)
instance (Typeable k, SafeCopy k) => Method (ValidateRecord k) where
  type MethodResult (ValidateRecord k) = Maybe k
  type MethodState  (ValidateRecord k) = RecordPool k
instance (Typeable k, SafeCopy k) => QueryEvent (ValidateRecord k)

data RemoveRecord k = RemoveRecord VCode
  deriving (Typeable)
$(deriveSafeCopy 0 'base ''RemoveRecord)
instance (Typeable k, SafeCopy k) => Method (RemoveRecord k) where
  type MethodResult (RemoveRecord k) = ()
  type MethodState  (RemoveRecord k) = RecordPool k
instance (Typeable k, SafeCopy k) => UpdateEvent (RemoveRecord k)

instance (Typeable k, SafeCopy k, Ord k) => IsAcidic (RecordPool k) where
  acidEvents = [ UpdateEvent (\(NewRecord key vcode etime) -> newRecord key vcode etime)
               , QueryEvent  (\(ValidateRecord vcode now)  -> validateRecord vcode now)
               , UpdateEvent (\(RemoveRecord vcode)        -> removeRecord vcode)
               ]

updated version one:
https://gist.github.com/notcome/df83f27b84088e0d9bcb

fixed a logical error in original word.

But now I have came with a better solution: grasping the benefit of both polymorphic setter and ADTs.

No, I can not use ADT to write a polymorphic setter, as I have no idea of how to write the fucking type signature.

So the above updated version is pretty good: M+N.