Move shift-time into top-level //zoo
I'm still unsure whether or not this is a good idea, but experimenting is a good way to find out!
This commit is contained in:
		
							parent
							
								
									3fdfa14355
								
							
						
					
					
						commit
						f895cb417a
					
				
					 5 changed files with 30 additions and 23 deletions
				
			
		| 
						 | 
				
			
			@ -2,3 +2,4 @@
 | 
			
		|||
:set -Wall
 | 
			
		||||
:set -XOverloadedStrings
 | 
			
		||||
:set -XRecordWildCards
 | 
			
		||||
:set -XTypeApplications
 | 
			
		||||
| 
						 | 
				
			
			@ -1,16 +1,35 @@
 | 
			
		|||
{-# LANGUAGE DeriveAnyClass #-}
 | 
			
		||||
{-# LANGUAGE DataKinds #-}
 | 
			
		||||
{-# LANGUAGE TypeOperators #-}
 | 
			
		||||
--------------------------------------------------------------------------------
 | 
			
		||||
module Main where
 | 
			
		||||
--------------------------------------------------------------------------------
 | 
			
		||||
import RIO
 | 
			
		||||
import RIO hiding (Handler)
 | 
			
		||||
import RIO.Text
 | 
			
		||||
import RIO.Time
 | 
			
		||||
import Data.String.Conversions (cs)
 | 
			
		||||
import Servant
 | 
			
		||||
import Data.Time.Clock.POSIX
 | 
			
		||||
import Prelude (putStrLn, putStr, print, getLine, read)
 | 
			
		||||
import Prelude (read)
 | 
			
		||||
import Text.ParserCombinators.ReadP
 | 
			
		||||
 | 
			
		||||
import qualified Network.Wai.Handler.Warp as Warp
 | 
			
		||||
--------------------------------------------------------------------------------
 | 
			
		||||
 | 
			
		||||
type Api = "run"
 | 
			
		||||
           :> QueryParam' '[Required] "offset" Text
 | 
			
		||||
           :> Get '[JSON] UTCTime
 | 
			
		||||
 | 
			
		||||
server :: Server Api
 | 
			
		||||
server = compute
 | 
			
		||||
  where
 | 
			
		||||
    compute :: Text -> Handler UTCTime
 | 
			
		||||
    compute x = do
 | 
			
		||||
      case parseInput x of
 | 
			
		||||
        Nothing -> throwError err401
 | 
			
		||||
        Just req -> do
 | 
			
		||||
          res <- liftIO $ shiftTime req
 | 
			
		||||
          pure res
 | 
			
		||||
 | 
			
		||||
data ShiftTimeRequest = ShiftTimeRequest
 | 
			
		||||
  { shiftSeconds :: Int
 | 
			
		||||
  , shiftMinutes :: Int
 | 
			
		||||
| 
						 | 
				
			
			@ -130,11 +149,4 @@ parseInput x =
 | 
			
		|||
    _ -> Nothing
 | 
			
		||||
 | 
			
		||||
main :: IO ()
 | 
			
		||||
main = do
 | 
			
		||||
  putStr "Enter an offset (e.g. -10d-30s): "
 | 
			
		||||
  x <- getLine
 | 
			
		||||
  case parseInput (cs x) of
 | 
			
		||||
    Nothing -> putStrLn "Try again!" >> main
 | 
			
		||||
    Just req -> do
 | 
			
		||||
      t <- shiftTime req
 | 
			
		||||
      putStrLn $ show t
 | 
			
		||||
main = Warp.run 8000 $ serve (Proxy @ Api) server
 | 
			
		||||
| 
						 | 
				
			
			@ -1,10 +1,10 @@
 | 
			
		|||
let
 | 
			
		||||
  briefcase = import /home/wpcarro/briefcase {};
 | 
			
		||||
in briefcase.buildHaskell.program {
 | 
			
		||||
  name = "shift-time";
 | 
			
		||||
{ briefcase, ... }:
 | 
			
		||||
 | 
			
		||||
briefcase.buildHaskell.program {
 | 
			
		||||
  name = "zoo";
 | 
			
		||||
  srcs = builtins.path {
 | 
			
		||||
    path = ./.;
 | 
			
		||||
    name = "shift-time-src";
 | 
			
		||||
    name = "zoo-src";
 | 
			
		||||
  };
 | 
			
		||||
  ghcExtensions = [
 | 
			
		||||
    "OverloadedStrings"
 | 
			
		||||
| 
						 | 
				
			
			@ -15,14 +15,7 @@ in briefcase.buildHaskell.program {
 | 
			
		|||
  deps = hpkgs: with hpkgs; [
 | 
			
		||||
    servant-server
 | 
			
		||||
    aeson
 | 
			
		||||
    wai-cors
 | 
			
		||||
    warp
 | 
			
		||||
    jwt
 | 
			
		||||
    unordered-containers
 | 
			
		||||
    base64
 | 
			
		||||
    http-conduit
 | 
			
		||||
    rio
 | 
			
		||||
    envy
 | 
			
		||||
    req
 | 
			
		||||
  ];
 | 
			
		||||
}
 | 
			
		||||
| 
						 | 
				
			
			@ -5,5 +5,6 @@ in briefcase.buildHaskell.shell {
 | 
			
		|||
    hspec
 | 
			
		||||
    rio
 | 
			
		||||
    string-conversions
 | 
			
		||||
    servant-server
 | 
			
		||||
  ];
 | 
			
		||||
}
 | 
			
		||||
		Loading…
	
	Add table
		Add a link
		
	
		Reference in a new issue