Clean up the code a little bit

src/Backfill.hs

@@ -11,6 +11,7 @@ import qualified Data.ByteString.Lazy as B
 import System.Console.CmdArgs
 import System.Directory (listDirectory, doesFileExist)
 import System.FilePath ((</>))
+import Data.List (find)
 
 import JSONParsing
 import Types
@@ -36,22 +37,28 @@ listCatalogDirectories settings = do
       doesFileExist catalogPath
 
 
-ensureSiteExists :: JSONSettings -> IO ()
+ensureSiteExists :: JSONSettings -> IO (Int)
 ensureSiteExists settings = do
     sitesResult <- Client.getAllSites settings
 
     case sitesResult of
         Right siteList ->
-            if any (\site -> Client.name site == site_name settings) siteList
+            case find (\site -> Client.name site == site_name settings) siteList of
-                then putStrLn $ site_name settings ++ " already exists!"
+            Just site -> do
-                else do
+                putStrLn $ site_name settings ++ " already exists!"
-                    putStrLn "leftychan.net does not exist. Creating..."
+                return $ Client.site_id site
-                    postResult <- Client.postSite settings
+            Nothing -> do
-                    case postResult of
+                putStrLn "leftychan.net does not exist. Creating..."
-                        Right _ -> putStrLn $ "Successfully created " ++ site_name settings ++ "."
+                postResult <- Client.postSite settings
-                        Left err -> do
+
-                            putStrLn $ "Failed to create leftychan.net. Error: " ++ show err
+                case postResult of
-                            exitFailure
+                    Right site -> do
+                        putStrLn $ "Successfully created " ++ site_name settings ++ ". " ++ show site
+                        return $ Client.site_id site
+                    Left err -> do
+                        putStrLn $ "Failed to create leftychan.net. Error: " ++ show err
+                        exitFailure
+
         Left err -> do
             putStrLn $ "Error fetching sites: " ++ show err
             exitFailure
@@ -61,9 +68,9 @@ processBackupDirectory :: JSONSettings -> IO ()
 processBackupDirectory settings = do
     putStrLn "JSON successfully read!"
     print settings  -- print the decoded JSON settings
-    ensureSiteExists settings
+    site_id_ <- ensureSiteExists settings
     dirs <- listCatalogDirectories settings
-    _ <- Client.getWebsiteBoards settings
+    _ <- Client.getSiteBoards settings site_id_
     putStrLn "Boards fetched!"
     mapM_ putStrLn dirs
     mapM_ processDir dirs

src/DataClient.hs

@@ -4,7 +4,7 @@
 module DataClient
   ( HttpError(..)
   , get
-  , getWebsiteBoards
+  , getSiteBoards
   , getAllSites
   , postSite
   , post
@@ -13,6 +13,7 @@ module DataClient
 
 import Network.HTTP.Simple
 import qualified Data.ByteString.Lazy as LBS
+import qualified Data.ByteString.Lazy.Char8 as LC8
 import Network.HTTP.Types.Status (statusCode)
 import Control.Exception.Safe (tryAny, SomeException)
 import qualified Data.ByteString.Char8 as C8
@@ -47,18 +48,32 @@ get settings path = do
     handleHttp (httpLBS req)
 
 
-post :: T.JSONSettings -> String -> LBS.ByteString -> IO (Either HttpError LBS.ByteString)
+post
-post settings path payload = do
+  :: T.JSONSettings
+  -> String
+  -> LBS.ByteString
+  -> Bool
+  -> IO (Either HttpError LBS.ByteString)
+post settings path payload return_repr = do
     let requestUrl = T.postgrest_url settings ++ path
     initReq <- parseRequest requestUrl
     let req = setRequestMethod "POST"
-            . setRequestHeader "Authorization" [C8.pack $ "Bearer " ++ T.jwt settings]
+            . setRequestHeader "Authorization" [ jwt_header ]
-            . setRequestHeader "Content-Type" ["application/json"]
+            . setRequestHeader "Content-Type" [ "application/json" ]
             . setRequestBodyLBS payload
+            . prefer
             $ initReq
+
     putStrLn $ "posting to " ++ requestUrl
     handleHttp (httpLBS req)
 
+    where
+      jwt_header = C8.pack $ "Bearer " ++ T.jwt settings
+      prefer =
+        if return_repr
+        then setRequestHeader "Prefer" [ "return=representation" ]
+        else id
+
 
 handleHttp :: IO (Response LBS.ByteString) -> IO (Either HttpError LBS.ByteString)
 handleHttp action = do
@@ -72,38 +87,29 @@ handleHttp action = do
         Left e -> return $ Left $ HttpException e
 
 
-getWebsiteBoards :: T.JSONSettings -> IO (Either HttpError [ String ])
+getSiteBoards :: T.JSONSettings -> Int -> IO (Either HttpError [ String ])
-getWebsiteBoards settings = do
+getSiteBoards settings site_id_ = get settings path >>= return . eitherDecodeResponse
-  response <- get settings path
-
-  case response of
-    Right body -> do
-      print body
-      undefined
-    Left err -> do
-      print err
-      return $ Left err
-
   where
-    path = "/boards?select=name,board_id,sites(site_id)&sites.name=eq."
+    path = "/boards?select=name&boards.site_id=eq." ++ show site_id_
-              ++ (T.site_name settings)
 
 
-postSite :: T.JSONSettings -> IO (Either HttpError LBS.ByteString)
+postSite :: T.JSONSettings -> IO (Either HttpError SiteResponse)
-postSite settings = do
+postSite settings =
-    let payload = encode $ object ["name" .= T.site_name settings, "url" .= T.site_url settings]
+    post settings "/sites" payload True >>= return . eitherDecodeResponse
-    post settings "/sites" payload
+
+    where
+      payload = encode $
+            object [ "name" .= T.site_name settings
+                   , "url"  .= T.site_url  settings
+                   ]
 
 
 getAllSites :: T.JSONSettings -> IO (Either HttpError [SiteResponse])
-getAllSites settings = do
+getAllSites settings = get settings "/sites" >>= return . eitherDecodeResponse
-    response <- get settings "/sites"
-    case response of
-        Right x -> do
-          putStrLn "getAllSites response:"
-          print x
 
-          return $ case eitherDecode x :: Either String [SiteResponse] of
+eitherDecodeResponse :: (FromJSON a) => Either HttpError LBS.ByteString -> Either HttpError a
-            Right sites -> Right sites
+eitherDecodeResponse (Left err) = Left err
-            Left _ -> Left $ StatusCodeError 500 "Failed to decode JSON"
+eitherDecodeResponse (Right bs) =
-        Left err -> return $ Left err
+    case eitherDecode bs of
+        Right val -> Right val
+        Left err -> Left $ StatusCodeError 500 $ LC8.pack $ "Failed to decode JSON: " ++ err