RadTestImpls.hs

-- We define a Test API. It will use a mutable IORef for
-- a database and it will let the text in the state
-- define if the server passes or fails.

-- This is part of the Helpers file for my rad service's spec tests.
-- I need to define in-memory strategies for validation and patching.

-- First we define our storage type as (IORef [Text]), meaning a mutable
-- list of Text objects.  We alos define our action type.
type TestAPI = APIBase () (IORef [Text])

-- Actions have constraints. We use heterogenous non-empty lists here,
-- as these have both a value-level AND type level representation, but
-- we could use anything we want.
type BaseTestAction c = ActionBase c (IORef [Text])

-- ListContains is a constraint that says, "you need to prove at compile time
-- that the context for this BasteTextAction contains an instanced of the Validated
-- type.
instance (ListContains n Validated xs) =>
            Patchable (BaseTestAction (HVect xs)) where
    
    -- Patches are generic, so we say, "We only accept patches that
    -- are showable for this code. 
    type PatchConstraint (BaseTestAction (HVect xs)) a = Show a
    
    -- This is our implementation of runPatch in the ActionCtxT monad that
    -- spock provides; runQuery is its hook to get our database context. For
    -- our tests, it's an IOVar. Everything else is my code.
    runPatch ereq p = do
        runQuery $ \iovar -> do
            let result = (p ^. strategy) ereq
            let resultText = Data.Text.pack . show $ result
            -- For tests, we just output the value of the patch to the IOVar
            -- so our spec tests can see it.
            modifyIORef iovar (resultText:)
            return $ Right result

-- Here we say, "Only actions which have NOT been validated support validation.
-- The validate method takes a target text (static, maybe a URL?), an auth value (from an auth
-- header in our test API) a request to validate.

-- For tests, we just let the target text dictate the result. My tests will run a server that
-- always validates and always invalidates for testing purposes.
instance (NotInList Validated xs ~ 'True) => CanValidate (BaseTestAction (HVect xs)) where
    validate truth _ _ = case truth of
        "pass" -> return $ Right True
        "fail" -> return $ Right False
        _      -> return $ Left "error"