This is why we functional program. Compiled then worked, first time. :)

FeatureApi.hs

{-# LANGUAGE ConstraintKinds       #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoImplicitPrelude     #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE TemplateHaskell       #-}
module Iseek.AuthorityMgr.FeatureApi where

import Control.Applicative (pure, (<$>))
import Control.Category    ((.))
import Control.Lens        (makePrisms, (^.))
import Control.Monad       ((>>=))
import Data.Foldable       (foldMap)
import Data.Function       (($))
import Data.Functor        (fmap)
import Data.Maybe          (maybe)
import Data.Tree           (Forest, Tree (Node), unfoldForestM)
import Data.Tuple          (uncurry)
import LDAP.Classy         (GidNumber)
import Text.Show           (Show)

import           Iseek.AuthorityMgr.Internal    (CanAuthMgr)
import qualified Iseek.DbCache.AccountFeature   as D
import qualified Iseek.DbCache.Feature          as D
import           Iseek.Types.AccountFeatureJSON (AccountFeatureJSON (AccountFeatureJSON))

data AccountFeature = AccountFeature D.Feature D.AccountFeature deriving Show
data SparseFeature  = NotSet D.Feature | IsSet AccountFeature deriving Show
makePrisms ''SparseFeature

accountFeatures :: CanAuthMgr m c e => GidNumber -> m (Forest AccountFeatureJSON)
accountFeatures gId =
  fmap (fmap toFeatureJson) . trimAndInterpolateForest <$> sparseFeatures
  where
    sparseFeatures :: CanAuthMgr m c e => m (Forest SparseFeature)
    sparseFeatures = D.rootFeatures >>= unfoldForestM getSparseFeature

    -- Build a sparse tree from the given feature. We'll end up
    -- with a tree where each node is a feature and optionally having
    -- configuration for that feature and account on the node.
    getSparseFeature :: CanAuthMgr m c e => D.Feature -> m (SparseFeature,[D.Feature])
    getSparseFeature f = do
      let fId = f ^. D.featureId
      afMay <- D.getAccountFeature gId fId
      let sf = maybe (NotSet f) (IsSet . AccountFeature f) afMay
      subFs <- D.subFeatures fId
      pure (sf,subFs)

trimAndInterpolateForest :: Forest SparseFeature -> Forest AccountFeature
trimAndInterpolateForest = foldMap trimAndInterpolateTree

trimAndInterpolateTree :: Tree SparseFeature -> Forest AccountFeature
trimAndInterpolateTree = fmap (uncurry interpolateForest) . trimTreeTop

-- Trim any excess off the top of the tree that is not set for this account
-- Returning back a potentially empty list of nodes.
trimTreeTop :: Tree SparseFeature -> [(AccountFeature,Forest SparseFeature)]
trimTreeTop (Node (NotSet _) []) = []
trimTreeTop (Node (NotSet _) f)  = foldMap trimTreeTop f
trimTreeTop (Node (IsSet af) f)  = [(af,f)]

interpolateForest :: AccountFeature -> Forest SparseFeature -> Tree AccountFeature
interpolateForest af = Node af . fmap (interpolateTree af)

-- For each tree, build a non sparse tree by interpolating the last
-- seen value as we decend if we hit a non set entry.
interpolateTree :: AccountFeature -> Tree SparseFeature -> Tree AccountFeature
interpolateTree l@(AccountFeature _ af) (Node (NotSet f) fs) =
  Node (AccountFeature f af) . fmap (interpolateTree l) $ fs
interpolateTree _ (Node (IsSet af) fs) =
  Node af . fmap (interpolateTree af) $ fs

toFeatureJson :: AccountFeature -> AccountFeatureJSON
toFeatureJson (AccountFeature f af) = AccountFeatureJSON
  (f^.D.featureName)
  (f^.D.featureDescription)
  (af^.D.accountFeatureTwoFactor)