kit-0.2: Kit/Repository.hs

{-

  Exposes the repositories.
  Allows you to:
    * copy down kit packages (getKit)
    * read kit specs (getKitSpec)
-}

module Kit.Repository (
    getKit,
    getKitSpec,
    webRepo,
    fileRepo,
    KitRepository
  ) where
    
  import Kit.Spec
  import Kit.Kit
  import Kit.Util
  import Data.List
  import Network.HTTP
  import Network.URI
  import Network.BufferType
  import Data.Maybe
  import Data.Traversable
  import Control.Monad
  import Control.Monad.Trans
  import Debug.Trace
  import Text.JSON
  import Kit.JSON
  import qualified Data.ByteString as BS

  data KitRepository = KitRepository {
    repoSave :: String -> FilePath -> IO (Maybe ()),
    repoRead :: String -> IO (Maybe String)
  }
  
  getKit :: KitRepository -> Kit -> FilePath -> IO (Maybe ())
  getKit kr k = repoSave kr (kitPackagePath k)
  
  getKitSpec :: KitRepository -> Kit -> KitIO KitSpec
  getKitSpec kr k = do
    mbKitStuff <- liftIO $ repoRead kr (kitSpecPath k)
    maybe (kitError $ "Missing " ++ kitFileName k) f mbKitStuff
    where f contents = maybeToKitIO ("Invalid KitSpec file for " ++ kitFileName k) $ case (decode contents) of
                          Ok a -> Just a
                          Error _ -> Nothing
  
  webRepo :: String -> KitRepository
  webRepo baseUrl = KitRepository save read where
    save = download 
    read = getBody

  fileRepo :: String -> KitRepository
  fileRepo baseDir = KitRepository save read where
    save src destPath = Just <$> copyFile (baseDir </> src) destPath
    read path = let file = (baseDir </> path) in do
      exists <- doesFileExist file
      sequenceA $ justTrue exists $ readFile file
      
  -- private!
  baseKitPath :: Kit -> String
  baseKitPath k = joinS ["kits", kitName k, kitVersion k] "/"
    where joinS xs x = foldl1 (++) $ intersperse x xs 
  
  kitPackagePath k = baseKitPath k ++ "/" ++ kitFileName k ++ ".tar.gz"
  kitSpecPath k = baseKitPath k ++ "/" ++ "KitSpec"
  
  getBody :: BufferType a => HStream a => String -> IO (Maybe a)
  getBody path = let
      request = defaultGETRequest_ . fromJust . parseURI
      checkResponse r = justTrue (rspCode r == (2,0,0)) r
      leftMaybe = either (const Nothing) Just 
    in do
      rr <- Network.HTTP.simpleHTTP $ request path
      return $ fmap rspBody $ leftMaybe rr
  
  download :: String -> FilePath -> IO (Maybe ())
  download url destination = do
      body <- getBody url
      sequenceA $ fmap (BS.writeFile destination) body