Route53 CLI (#156)

* fission-cli up
* fission-cli watch

library/Fission/AWS/DomainName/Types.hs

@@ -1,6 +1,7 @@
 module Fission.AWS.DomainName.Types (DomainName (..)) where
 
-import RIO
+import           RIO
+import qualified RIO.ByteString.Lazy as Lazy
 
 import Data.Aeson
 import Data.Swagger (ToSchema (..))
@@ -26,3 +27,9 @@ instance MimeRender PlainText DomainName where
 
 instance MimeRender OctetStream DomainName where
   mimeRender _ = UTF8.textToLazyBS . getDomainName
+
+instance MimeUnrender PlainText DomainName where
+  mimeUnrender _proxy bs =
+    case decodeUtf8' $ Lazy.toStrict bs of
+      Left err  -> Left $ show err
+      Right txt -> Right $ DomainName txt

library/Fission/CLI.hs

@@ -37,7 +37,7 @@ cli = do
     Watch.command    cfg
   runCLI
   where
-    version     = "1.14.0"
+    version     = "1.15.0"
     description = "CLI to interact with Fission services"
     detail      = mconcat [ "Fission makes developing, deploying, updating "
                           , "and iterating on web applications quick and easy."

library/Fission/CLI/Auth.hs

@@ -14,6 +14,7 @@ import qualified System.Console.ANSI as ANSI
 
 import qualified Data.Yaml as YAML
 import           Servant
+import           Servant.Client
 
 import           Fission.Internal.Constraint
 import           Fission.Internal.Orphanage.BasicAuthData ()
@@ -35,15 +36,24 @@ cachePath = do
   home <- getHomeDirectory
   return $ home </> ".fission.yaml"
 
-withAuth :: (MonadRIO cfg m, HasLogFunc cfg) => (BasicAuthData -> m ()) -> m ()
+withAuth :: MonadRIO   cfg m
+         => HasLogFunc cfg
+         => (BasicAuthData -> m (Either ClientError a))
+         -> m (Either SomeException a)
 withAuth action = get >>= \case
   Right auth ->
-    action auth
+    action auth >>= pure . \case
+      Right result -> Right result
+      Left err -> Left $ toException err
 
   Left err -> do
     logError $ displayShow err
+
     liftIO $ ANSI.setSGR [ANSI.SetColor ANSI.Foreground ANSI.Vivid ANSI.Red]
     UTF8.putText "🚫 Unable to read credentials. Try logging in with "
+
     liftIO $ ANSI.setSGR [ANSI.SetColor ANSI.Foreground ANSI.Vivid ANSI.Blue]
     UTF8.putText "fission-cli login"
+
     liftIO $ ANSI.setSGR [ANSI.Reset]
+    return . Left $ toException err

library/Fission/CLI/Command/Up.hs

@@ -3,22 +3,25 @@ module Fission.CLI.Command.Up (command, up) where
 
 import           RIO
 import           RIO.Directory
+import           RIO.FilePath
 import           RIO.Process (HasProcessContext)
 
 import           Data.Has
-import           System.FilePath
 
 import           Options.Applicative.Simple (addCommand)
 import           Options.Applicative (strArgument, metavar, help, value)
 
 import           Fission.Internal.Constraint
+import           Fission.Internal.Exception
 
 import qualified Fission.Storage.IPFS as IPFS
 import qualified Fission.IPFS.Types   as IPFS
 import qualified Fission.Web.Client   as Client
 
-import qualified Fission.CLI.Auth    as Auth
-import qualified Fission.CLI.Pin     as CLI.Pin
+import qualified Fission.CLI.Display.Error as Error
+import qualified Fission.CLI.Auth          as Auth
+import qualified Fission.CLI.Pin           as CLI.Pin
+import qualified Fission.CLI.DNS           as CLI.DNS
 import           Fission.CLI.Config.Types
 
 -- | The command to attach to the CLI tree
@@ -34,8 +37,12 @@ command cfg =
   addCommand
     "up"
     "Keep your current working directory up"
-    (runRIO cfg . up)
-    (strArgument $ metavar "Location" <> help "The location of the assets you want to upload" <> value "./")
+    (\dir -> runRIO cfg $ up dir)
+    (strArgument $ mconcat
+      [ metavar "Location"
+      , help    "The location of the assets you want to upload"
+      , value   "./"
+      ])
 
 -- | Sync the current working directory to the server over IPFS
 up :: MonadRIO          cfg m
@@ -46,11 +53,13 @@ up :: MonadRIO          cfg m
    => Has Client.Runner cfg
    => String
    -> m ()
-up dir = do
-  curr <- getCurrentDirectory
-  let dir' = if isAbsolute dir then dir else curr </> dir
+up dir = handleWith_ Error.put' do
+  currDir <- getCurrentDirectory
+  cid <- liftE . IPFS.addDir $ if isAbsolute dir
+                                 then dir
+                                 else currDir </> dir
+
   logDebug "Starting single IPFS add locally of"
 
-  IPFS.addDir dir' >>= \case
-    Right cid -> Auth.withAuth (void . CLI.Pin.run cid)
-    Left  err -> logError $ displayShow err
+  liftE . Auth.withAuth $ CLI.Pin.run cid
+  liftE . Auth.withAuth $ CLI.DNS.update cid

library/Fission/CLI/Command/Watch.hs

@@ -7,12 +7,12 @@ module Fission.CLI.Command.Watch
 
 import           RIO
 import           RIO.Directory
+import           RIO.FilePath
 import           RIO.Process (HasProcessContext)
 import qualified RIO.Text as Text
 import           RIO.Time
 
 import           Data.Has
-import           System.FilePath
 
 import           Options.Applicative.Simple (addCommand)
 import           Options.Applicative (strArgument, metavar, help, value)
@@ -27,11 +27,15 @@ import qualified Fission.Time         as Time
 
 import           Fission.IPFS.CID.Types
 import qualified Fission.IPFS.Types as IPFS
+import qualified Fission.AWS.Types  as AWS
+
+import           Fission.Internal.Exception
+import           Fission.CLI.Display.Error as CLI.Error
 
 import qualified Fission.CLI.Auth          as Auth
 import           Fission.CLI.Config.Types
-import qualified Fission.CLI.Display.Error as CLI.Error
 import qualified Fission.CLI.Pin           as CLI.Pin
+import qualified Fission.CLI.DNS           as CLI.DNS
 
 -- | The command to attach to the CLI tree
 command :: MonadIO m
@@ -46,8 +50,12 @@ command cfg =
   addCommand
     "watch"
     "Keep your working directory in sync with the IPFS network"
-    (runRIO cfg . watcher)
-    (strArgument $ metavar "Location" <> help "The location of the assets you want to watch" <> value "./")
+    (\dir -> runRIO cfg $ watcher dir)
+    (strArgument $ mconcat
+      [ metavar "Location"
+      , help    "The location of the assets you want to watch"
+      , value   "./"
+      ])
 
 -- | Continuously sync the current working directory to the server over IPFS
 watcher :: MonadRIO          cfg m
@@ -58,26 +66,20 @@ watcher :: MonadRIO          cfg m
         => Has IPFS.Timeout  cfg
         => String
         -> m ()
-watcher dir= do
+watcher dir = handleWith_ CLI.Error.put' do
   cfg <- ask
   curr <- getCurrentDirectory
-  let dir' = if isAbsolute dir then dir else curr </> dir
+  let absDir = if isAbsolute dir then dir else curr </> dir
   UTF8.putText $ "👀 Watching " <> Text.pack dir <> " for changes...\n"
 
-  IPFS.addDir dir' >>= \case
-    Left err ->
-      CLI.Error.put' $ textDisplay err
-
-    Right initCID ->
-      Auth.withAuth $ CLI.Pin.run initCID >=> \case
-        Left err ->
-          CLI.Error.put' err
+  initCID  <- liftE $ IPFS.addDir absDir
+  CID hash <- liftE . Auth.withAuth $ CLI.Pin.run initCID
 
-        Right (CID hash) -> liftIO $ FS.withManager \watchMgr -> do
-          hashCache <- newMVar hash
-          timeCache <- newMVar =<< getCurrentTime
-          void $ handleTreeChanges timeCache hashCache watchMgr cfg dir'
-          forever $ liftIO $ threadDelay 1000000 -- Sleep main thread
+  liftIO $ FS.withManager \watchMgr -> do
+    hashCache <- newMVar hash
+    timeCache <- newMVar =<< getCurrentTime
+    void $ handleTreeChanges timeCache hashCache watchMgr cfg absDir
+    forever $ liftIO $ threadDelay 1000000 -- Sleep main thread
 
 handleTreeChanges :: HasLogFunc        cfg
                   => Has Client.Runner cfg
@@ -91,7 +93,7 @@ handleTreeChanges :: HasLogFunc        cfg
                   -> FilePath
                   -> IO StopListening
 handleTreeChanges timeCache hashCache watchMgr cfg dir =
-  FS.watchTree watchMgr dir (const True) . const $ runRIO cfg do
+  FS.watchTree watchMgr dir (const True) \_ -> runRIO cfg do
     now     <- getCurrentTime
     oldTime <- readMVar timeCache
 
@@ -109,4 +111,21 @@ handleTreeChanges timeCache hashCache watchMgr cfg dir =
           Right cid@(CID newHash) -> do
             oldHash <- swapMVar hashCache newHash
             logDebug $ "CID: " <> display oldHash <> " -> " <> display newHash
-            when (oldHash /= newHash) $ Auth.withAuth (void . CLI.Pin.run cid)
+            when (oldHash /= newHash) . void $ pinAndUpdateDNS cid
+
+pinAndUpdateDNS :: MonadRIO          cfg m
+                => HasLogFunc        cfg
+                => Has Client.Runner cfg
+                => HasProcessContext cfg
+                => Has IPFS.BinPath  cfg
+                => Has IPFS.Timeout  cfg
+                => CID
+                -> m (Either SomeException AWS.DomainName)
+pinAndUpdateDNS cid =
+  Auth.withAuth (CLI.Pin.run cid) >>= \case
+    Left err -> do
+      logError $ displayShow err
+      return $ Left err
+
+    Right _ ->
+      Auth.withAuth $ CLI.DNS.update cid

library/Fission/CLI/DNS.hs

@@ -0,0 +1,52 @@
+-- | Update DNS via the CLI
+module Fission.CLI.DNS (update) where
+
+import RIO
+
+import Data.Has
+
+import Servant
+import Servant.Client
+
+import qualified Fission.Config as Config
+import           Fission.Internal.Constraint
+
+import           Fission.IPFS.CID.Types
+
+import qualified Fission.Web.Client      as Client
+import qualified Fission.Web.DNS.Client  as DNS.Client
+
+import           Fission.CLI.Display.Error   as CLI.Error
+import qualified Fission.CLI.Display.Loader  as CLI
+import           Fission.CLI.Display.Success as CLI.Success
+
+import qualified Fission.AWS.Types as AWS
+
+update :: MonadRIO          cfg m
+    => HasLogFunc        cfg
+    => Has Client.Runner cfg
+    => CID
+    -> BasicAuthData
+    -> m (Either ClientError AWS.DomainName)
+update cid@(CID hash) auth = do
+  logDebug $ "Updating DNS to " <> display hash
+
+  Client.Runner runner <- Config.get
+  update' runner auth cid >>= \case
+    Right domain -> do
+      CLI.Success.dnsUpdated $ AWS.getDomainName domain
+      return $ Right domain
+
+    Left err -> do
+      CLI.Error.put' err
+      return $ Left err
+
+update' :: MonadIO m
+        => (ClientM AWS.DomainName -> IO a)
+        -> BasicAuthData
+        -> CID
+        -> m a
+update' runner auth cid =
+  liftIO . CLI.withLoader 50000
+         . runner
+         $ DNS.Client.update auth cid

library/Fission/CLI/Display/Success.hs

@@ -2,6 +2,7 @@
 module Fission.CLI.Display.Success
   ( live
   , putOk
+  , dnsUpdated
   ) where
 
 import RIO
@@ -20,3 +21,8 @@ putOk msg = do
   liftIO $ ANSI.setSGR [ANSI.SetColor ANSI.Foreground ANSI.Vivid ANSI.Green]
   UTF8.putText $ "✅ " <> msg <> "\n"
   liftIO $ ANSI.setSGR [ANSI.Reset]
+
+dnsUpdated :: MonadIO m => Text -> m ()
+dnsUpdated domain = do
+  UTF8.putText "📝 DNS Updated. Check out your site at: \n"
+  UTF8.putText $ "🔗 " <> domain  <> "\n"

library/Fission/Web.hs

@@ -18,21 +18,20 @@ import           Servant
 
 import qualified Fission.Config     as Config
 import           Fission.User
-import           Fission.Web.Server
 import qualified Fission.IPFS.Types as IPFS
-import           Fission.File.Types ()
+
 import           Fission.Internal.Orphanage.PlainText ()
 import           Fission.Internal.Orphanage.OctetStream ()
 
-import qualified Fission.Web.User        as User
 import qualified Fission.Web.Auth        as Auth
+import qualified Fission.Web.DNS         as DNS
 import qualified Fission.Web.IPFS        as IPFS
 import qualified Fission.Web.Ping        as Ping
-import qualified Fission.Web.DNS         as DNS
-
 import qualified Fission.Web.Routes      as Web
+import           Fission.Web.Server
 import qualified Fission.Web.Swagger     as Web.Swagger
 import qualified Fission.Web.Types       as Web
+import qualified Fission.Web.User        as User
 
 import qualified Network.AWS.Auth  as AWS
 import qualified Fission.AWS.Types as AWS

library/Fission/Web/Auth.hs

@@ -1,5 +1,7 @@
 module Fission.Web.Auth
-  ( server
+  ( ExistingUser
+  , HerokuAddOnAPI 
+  , server
   , context
   , basic
   , user
@@ -16,6 +18,9 @@ import Fission.Storage.Query
 import Fission.User as User
 import Fission.Web.Server
 
+type ExistingUser = BasicAuth "existing user" User
+type HerokuAddOnAPI = BasicAuth "heroku add-on api" ByteString
+
 server :: HasServer api '[BasicAuthCheck User, BasicAuthCheck ByteString]
        => Proxy api
        -> cfg

library/Fission/Web/DNS/Client.hs

@@ -0,0 +1,13 @@
+module Fission.Web.DNS.Client (update) where
+
+import RIO
+
+import Servant
+import Servant.Client
+
+import qualified Fission.AWS.DomainName.Types as AWS
+import           Fission.IPFS.CID.Types
+import qualified Fission.Web.Routes           as Routes
+
+update :: BasicAuthData -> CID -> ClientM AWS.DomainName
+update = client (Proxy :: Proxy Routes.DNSRoute)

library/Fission/Web/Routes.hs

@@ -6,6 +6,7 @@ module Fission.Web.Routes
   , IPFSPrefix
   , IPFSRoute
   , PingRoute
+  , DNSRoute
   ) where
 
 import Servant