Merge pull request #3 from HaskellCNOrg/master

Upgrade to snap-0.8.x

Makefile

@@ -0,0 +1,14 @@
+DIST=dist
+
+default: build
+
+clean:
+	rm -rf $(DIST)
+
+build: clean
+	cabal configure
+	cabal build
+
+install: build
+	cabal install
+

snaplet-environments.cabal

@@ -7,7 +7,7 @@ Name:                snaplet-environments
 -- The package version. See the Haskell package versioning policy
 -- (http://www.haskell.org/haskellwiki/Package_versioning_policy) for
 -- standards guiding when and how versions should be incremented.
-Version:             0.1
+Version:             0.2
 
 -- A short (one-line) description of the package.
 Synopsis:            Provides ability to easly read configuration based on given app environment given at command line, envs are defined in app configuration file
@@ -52,22 +52,30 @@ Library
 
   -- Packages needed in order to build this package.
   Build-depends:
-    base >= 4 && < 5,
-    snap == 0.7.*,
-    snap-core  == 0.7.*,
-    mtl >= 2 && < 3,
-    configurator >= 0.2 && < 0.3,
-    regex-tdfa >= 1.1.8 && < 1.2, 
-    unordered-containers >= 0.1.4.3 && < 0.2,
-    text >= 0.11 && < 0.12,
-    bson >= 0.1.6 && < 0.2
+    base                 >= 4 && < 5,
+    snap                 == 0.8.*,
+    snap-core            == 0.8.*,
+    mtl                  >= 2 && < 3,
+    configurator         >= 0.2 && < 0.3,
+    regex-tdfa           >= 1.1.8 && < 1.2, 
+    unordered-containers >= 0.2 && < 0.3,
+    text                 >= 0.11 && < 0.12,
+    bson                 >= 0.1.7 && < 0.2
 
   -- Extra tools (e.g. alex, hsc2hs, ...) needed to build the source.
   -- Build-tools:    
 
+  if impl(ghc >= 6.12.0)
+    ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields -O2
+                 -fno-warn-orphans -fno-warn-unused-do-bind
+                 -fno-spec-constr-count
+  else
+    ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields -O2
+                 -fno-warn-orphans
+
   extensions: 
       OverloadedStrings
     , FlexibleInstances
     , TypeSynonymInstances
     , MultiParamTypeClasses 
-
+

src/Snap/Snaplet/Environments.hs

@@ -1,37 +1,66 @@
 module Snap.Snaplet.Environments
     ( module Data.Configurator
+    , lookupConfig
+    , lookupConfigDefault
+    , lookupEnv
     , lookupEnvDefault
     , module Snap.Snaplet.Environments.Instances ) 
     where
 
 import           Control.Monad.Reader
+import           Data.Maybe (fromMaybe)
 import           Data.Configurator
 import           Data.Configurator.Types
 import qualified Data.HashMap.Lazy                   as HM
-import           Data.List                           (filter, find)
+import           Data.List (find)
 import qualified Data.Text                           as T
 import           Snap.Snaplet
 import           Snap.Snaplet.Environments.Instances
 import           System.Environment                  (getArgs)
 import           Text.Regex.TDFA
 
+-----------------------------------------------------------
+-- 
+
+lookupConfig :: (MonadIO (m b v), MonadSnaplet m, Configured a) => Name -> m b v (Maybe a)
+lookupConfig name = do
+    config <- getSnapletUserConfig
+    liftIO $ Data.Configurator.lookup config name
+
+lookupConfigDefault :: (MonadIO (m b v), MonadSnaplet m, Configured a) 
+                          => Name  -- ^ Key
+                          -> a       -- ^ default value
+                          -> m b v a
+lookupConfigDefault name def = liftM (fromMaybe def) (lookupConfig name)
+
+
+
+-----------------------------------------------------------
+-- Look up value under environments sub group.
+
+
+-- | Look up a given name without default value.
+-- 
+lookupEnv :: (Configured a, Monad (m b v), MonadSnaplet m, MonadIO (m b v)) => Name -> m b v (Maybe a)
+lookupEnv name = do
+  mainConf <- getSnapletUserConfig
+  subName <- getNameForCurEnv name mainConf
+  liftIO $ Data.Configurator.lookup mainConf subName
 
 -- | This function takes current env subconfig and at its base
 --   looks up given name
+-- 
 lookupEnvDefault :: (Configured a, Monad (m b v), MonadSnaplet m, MonadIO (m b v)) => Name -> a -> m b v a
-lookupEnvDefault name def = do
-  mainConf <- getSnapletUserConfig
-  subName <- getNameForCurEnv name mainConf
-  mv <- liftIO $ Data.Configurator.lookup mainConf subName
-  case mv of
-    Nothing -> liftIO $ lookupDefault def mainConf name
-    Just v  -> (liftIO $ putStrLn "Just") >> return v
+lookupEnvDefault name def = liftM (fromMaybe def) (lookupEnv name)
+
+-----------------------------------------------------------
 
 getNameForCurEnv :: (Monad (m b v), MonadSnaplet m, MonadIO (m b v)) => Name -> Config -> m b v Name
 getNameForCurEnv name cfg = do
   env <- getCurrentEnv cfg
   return $ T.pack $ "environments." ++ env ++ "." ++ (T.unpack name)
 
+
 getCurrentEnv :: (Monad (m b v), MonadSnaplet m, MonadIO (m b v)) => Config -> m b v String
 getCurrentEnv cfg = do
   mopt <- return . find (\a -> take 1 a == "@") =<< liftIO getArgs
@@ -40,9 +69,9 @@ getCurrentEnv cfg = do
       hm <- liftIO $ getMap cfg
       case filter (\k -> (T.unpack k) =~ ("app.environments." :: String)) $ HM.keys hm of
         []     -> error "You have to put at least one env definition in your config file."
-        (x:xs) -> return $ T.unpack $ (T.split (== '.') x) !! 2
+        (x:_) -> return $ T.unpack $ (T.split (== '.') x) !! 2
     Just opt -> do
       hm <- liftIO $ getMap cfg
       case length (filter (\k -> (T.unpack k) =~ ("app.environments." ++ (tail opt))) $ HM.keys hm) > 0 of
         True  -> return $ tail opt
-        False -> error $ "Given env name: " ++ opt ++ " wasn't found in your config file."
+        False -> error $ "Given env name: " ++ opt ++ " wasn't found in your config file."