Browse Source

Add the ability to add records to a PostgreSQL database

master
Peter J. Jones 2 years ago
parent
commit
ebb763ae45
Signed by: Peter Jones <pjones@devalot.com> GPG Key ID: 9DAFAA8D01941E49

+ 3
- 2
courses/secure-coding.nix View File

@@ -16,7 +16,7 @@
merkel.services.home.archives = lib.singleton {
src = pkgs.fetchurl {
url = "https://www.devalot.com/files/secure-coding/secure-coding.tar.xz";
sha256 = "1b388f77bf7b8389cd05c6e0a94f31e10c60552681a401336f479cbf9c6dc21c";
sha256 = "d99141558a2e0caa5a4cac2b4d7629daed70d352c1ad2245a0f5dd657dcd1af3";
};
};

@@ -28,6 +28,7 @@
emacs
firefox
jdk
maven
nodejs
sqlite
sqlite-interactive
@@ -39,5 +40,5 @@
];

# Deployment:
deployment.ec2.ami = "ami-c96f95b1"; # Pre-configured AMI for this course.
deployment.ec2.ami = "ami-cbf131b3"; # Pre-configured AMI for this course.
}

+ 20
- 0
default.nix View File

@@ -0,0 +1,20 @@
# These arguments are so you can override settings from the command
# line using the `nix-hs' tool.
{ nixpkgs ? import <nixpkgs> { }
, compiler ? "default"
, profiling ? false
}:

let
pkgs = nixpkgs;

buildInputs = with pkgs; [
# List extra dependencies here.
nixops
mkpasswd
pwgen
];

in
pkgs.nix-hs.interactive ./merkel.nix
{ inherit compiler profiling buildInputs; }

lib/Merkel/Operations/Generate.hs → lib/Merkel/Operations/Create.hs View File

@@ -17,9 +17,9 @@ the LICENSE file.

--------------------------------------------------------------------------------
-- | Generate a complete course.
module Merkel.Operations.Generate
( Config (..)
, makeCourseFiles
module Merkel.Operations.Create
( Details (..)
, create
) where

--------------------------------------------------------------------------------
@@ -34,32 +34,42 @@ import System.FilePath

--------------------------------------------------------------------------------
import Merkel.Types.Course
import Merkel.Types.Merkel
import Merkel.Util.Courses
import Merkel.Util.Passwords
import Merkel.Util.Templates

--------------------------------------------------------------------------------
data Config = Config
{ configCourseName :: Text
, configCourseNixFile :: FilePath
, configTemplateFile :: FilePath
, configOutputDir :: FilePath
, configNumStudents :: Int
data Details = Details
{ detailsCourseName :: Text
, detailsCourseNixFile :: FilePath
, detailsTemplateFile :: FilePath
, detailsOutputDir :: FilePath
, detailsNumStudents :: Int
}

--------------------------------------------------------------------------------
makeCourseFiles :: (MonadIO m) => Config -> m (Either String Course)
makeCourseFiles Config {..} = do
c <- generateCourse configCourseName configNumStudents
liftIO (ByteString.writeFile jsonFileName (encode c))
status <- render bindings configTemplateFile nixFileName

case status of
RenderSuccess -> return (Right c)
create :: (MonadIO m) => Details -> Merkel m (Either String Course)
create Details {..} = do
password <- generatePassword' 10

let course = Course { courseName = detailsCourseName
, coursePassword = password
, courseTemplate = Text.pack detailsTemplateFile
, courseNixFile = Text.pack nixFileName
}

vms <- createCourse course detailsNumStudents
liftIO (ByteString.writeFile jsonFileName (encode vms))
renderStatus <- render bindings detailsTemplateFile nixFileName

case renderStatus of
RenderSuccess -> return (Right course)
RenderFail e -> return (Left e)

where
jsonFileName :: FilePath
jsonFileName = configOutputDir </> Text.unpack configCourseName <.> "json"
jsonFileName = detailsOutputDir </> Text.unpack detailsCourseName <.> "json"

nixFileName :: FilePath
nixFileName = replaceExtension jsonFileName "nix"
@@ -69,6 +79,6 @@ makeCourseFiles Config {..} = do

bindings :: Map Text Text
bindings = Map.fromList [ ("jsonFile", basenameT jsonFileName)
, ("courseNix", basenameT configCourseNixFile)
, ("courseName", configCourseName)
, ("courseNix", basenameT detailsCourseNixFile)
, ("courseName", detailsCourseName)
]

+ 35
- 0
lib/Merkel/Operations/Migrate.hs View File

@@ -0,0 +1,35 @@
{-

This file is part of the package merkel. It is subject to the license
terms in the LICENSE file found in the top-level directory of this
distribution and at:

git://git.devalot.com/merkel.git

No part of this package, including this file, may be copied, modified,
propagated, or distributed except according to the terms contained in
the LICENSE file.

-}

--------------------------------------------------------------------------------
module Merkel.Operations.Migrate
( migrateSchema
) where

--------------------------------------------------------------------------------
import Control.Monad.IO.Class (MonadIO)

--------------------------------------------------------------------------------
import Merkel.Types.Course
import Merkel.Types.Merkel
import Merkel.Types.Student
import Merkel.Types.VirtualMachine
import Merkel.Util.Groundhog

--------------------------------------------------------------------------------
migrateSchema :: (MonadIO m) => Merkel m ()
migrateSchema = withDB_ $ runMigration $ do
migrate (undefined :: Course)
migrate (undefined :: Student)
migrate (undefined :: VirtualMachine)

+ 116
- 0
lib/Merkel/Operations/Snap/JoinCourse.hs View File

@@ -0,0 +1,116 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}

{-

This file is part of the package merkel. It is subject to the license
terms in the LICENSE file found in the top-level directory of this
distribution and at:

git://git.devalot.com/merkel.git

No part of this package, including this file, may be copied, modified,
propagated, or distributed except according to the terms contained in
the LICENSE file.

-}

--------------------------------------------------------------------------------
module Merkel.Operations.Snap.JoinCourse
( JoinCourse
, joinCourseInit
) where

--------------------------------------------------------------------------------
import Control.Lens
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.Trans.Maybe
import Data.Aeson (FromJSON, ToJSON)
import Data.Text (Text)
import GHC.Generics
import Snap.Core
import Snap.Snaplet
import Snap.Snaplet.Session

--------------------------------------------------------------------------------
import Merkel.Types.Course
import Merkel.Types.Merkel
import Merkel.Types.Student
import Merkel.Types.VirtualMachine
import Merkel.Util.Courses
import Merkel.Util.Groundhog
import Merkel.Util.VirtualMachines

--------------------------------------------------------------------------------
data JoinCourse = JoinCourse
{ _merkel :: MerkelClone
, _cookies :: Snaplet SessionManager
}

makeLenses ''JoinCourse

--------------------------------------------------------------------------------
data Message = Message
{ msgStudentName :: Text
, msgCoursePassword :: Text
} deriving Generic

instance FromJSON Message

--------------------------------------------------------------------------------
data Assigned = CourseUnavailable | Assigned Text Text
deriving Generic

instance ToJSON Assigned

--------------------------------------------------------------------------------
-- | FIXME: What is the best way to access the @cookies@ lens from the
-- top-level snaplet?
joinCourseInit :: MerkelClone -> Snaplet SessionManager -> SnapletInit b JoinCourse
joinCourseInit mc sess = makeSnaplet "join" "Join Course" Nothing $ do
addRoutes [ ("join", joinCourseHandler ) ]
return (JoinCourse mc sess)

--------------------------------------------------------------------------------
joinCourseHandler :: Handler b JoinCourse ()
joinCourseHandler = do
s <- with cookies (getFromSession "student")


with cookies (setInSession "foo" "bar" >> commitSession)

-- Apache fails unless you set Content-Length to 0.
modifyResponse $ setContentLength 0 . setContentType "application/json"


--------------------------------------------------------------------------------
getExistingAssignment :: (MonadIO m)
=> Maybe Text
-- ^ Existing student ID.

-> Text
-- ^ Course password.

-> Merkel m (Maybe (AutoKey Student, VirtualMachine))

getExistingAssignment Nothing _ = return Nothing
getExistingAssignment (Just tid) password =
runMaybeT $ do
student <- MaybeT $ return (textToKey tid)
course <- MaybeT $ findCourseByPassword password
vm <- MaybeT $ findVmByStudent course student
return (student, vm)

--------------------------------------------------------------------------------
makeNewAssignment :: (MonadIO m)
=> Maybe Text
-- ^ Existing student ID.

-> Message
-- ^ Join request.

-> Merkel m (Maybe (Student, VirtualMachine))


makeNewAssignment = undefined

+ 28
- 0
lib/Merkel/Types/Config.hs View File

@@ -0,0 +1,28 @@
{-

This file is part of the package merkel. It is subject to the license
terms in the LICENSE file found in the top-level directory of this
distribution and at:

git://git.devalot.com/merkel.git

No part of this package, including this file, may be copied, modified,
propagated, or distributed except according to the terms contained in
the LICENSE file.

-}

--------------------------------------------------------------------------------
-- | Merkel configuration.
module Merkel.Types.Config
( Config (..)
) where

--------------------------------------------------------------------------------
import Data.Text (Text)

--------------------------------------------------------------------------------
data Config = Config
{ configConnectString :: Text -- ^ Database connection string
, configPoolSize :: Int -- ^ Number of connections in pool
}

+ 30
- 10
lib/Merkel/Types/Course.hs View File

@@ -1,4 +1,10 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}

{-

@@ -15,24 +21,38 @@ the LICENSE file.
-}

--------------------------------------------------------------------------------
module Merkel.Types.Course
( Course (..)
) where
module Merkel.Types.Course where

--------------------------------------------------------------------------------
import Data.Aeson (ToJSON, FromJSON)
import Data.Aeson (ToJSON)
import Data.Text (Text)
import GHC.Generics
import Merkel.Types.Password
import Merkel.Types.VirtualMachine
import Merkel.Util.Groundhog

--------------------------------------------------------------------------------
data Course = Course
{ courseName :: Text -- ^ The name of the class.
, coursePassword :: Password -- ^ The password for accessing the course.
, courseVMs :: [VirtualMachine] -- ^ Virtual Machines for this course.
{ courseName :: Text -- ^ The name of the class.
, coursePassword :: Password -- ^ The password for accessing the course.
, courseTemplate :: Text -- ^ Template Nix file for this course.
, courseNixFile :: Text -- ^ The generated Nix file backing this course.
} deriving (Generic, Show)

--------------------------------------------------------------------------------
mkPersist merkelCodegenConfig [groundhog|
entity: Course
constructors:
- name: Course
fields:
- name: coursePassword
embeddedType:
- { name: passwordClear, dbName: clear }
- { name: passwordHashed, dbName: hashed }
uniques:
- name: unique_name
type: constraint
fields: [ courseName ]
|]

--------------------------------------------------------------------------------
instance ToJSON Course
instance FromJSON Course

+ 99
- 0
lib/Merkel/Types/Merkel.hs View File

@@ -0,0 +1,99 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE RecordWildCards #-}

{-

This file is part of the package merkel. It is subject to the license
terms in the LICENSE file found in the top-level directory of this
distribution and at:

git://git.devalot.com/merkel.git

No part of this package, including this file, may be copied, modified,
propagated, or distributed except according to the terms contained in
the LICENSE file.

-}

--------------------------------------------------------------------------------
-- | Monad Transformer.
module Merkel.Types.Merkel
( Merkel
, MerkelClone
, mkDbPool
, withDB
, withDB_
, cloneMerkel
, runMerkel
, runMerkel'
, runMerkelClone
) where

--------------------------------------------------------------------------------
import Control.Monad (void)
import Control.Monad.RWS
import Data.Pool
import qualified Data.Text as Text
import Database.Groundhog.Core (Action)
import Database.Groundhog.Postgresql
import Merkel.Types.Config

--------------------------------------------------------------------------------
data Env = Env
{ envConfig :: Config
, envConnectionPool :: Pool Postgresql
}

--------------------------------------------------------------------------------
newtype Merkel m a = Merkel
{ unM :: RWST Env () () m a }
deriving ( Functor, Applicative, Monad, MonadIO
, MonadReader Env
)

--------------------------------------------------------------------------------
data MerkelClone = MerkelClone Env

--------------------------------------------------------------------------------
cloneMerkel :: (Monad m) => Merkel m MerkelClone
cloneMerkel = MerkelClone <$> ask

--------------------------------------------------------------------------------
mkDbPool :: (MonadIO m) => Config -> m (Pool Postgresql)
mkDbPool Config{..} =
createPostgresqlPool (Text.unpack configConnectString)
configPoolSize

--------------------------------------------------------------------------------
withDB :: (MonadIO m) => Action Postgresql a -> Merkel m a
withDB action = do
pool <- asks envConnectionPool
liftIO (withResource pool (runDbConn action))

--------------------------------------------------------------------------------
withDB_ :: (MonadIO m) => Action Postgresql a -> Merkel m ()
withDB_ = void . withDB

--------------------------------------------------------------------------------
runMerkel' :: (MonadIO m) => Pool Postgresql -> Config -> Merkel m a -> m a
runMerkel' pool config merkel = do
(x, _, _) <- runRWST (unM merkel) env ()
return x
where
env :: Env
env = Env { envConfig = config
, envConnectionPool = pool
}

--------------------------------------------------------------------------------
runMerkel :: (MonadIO m) => Config -> Merkel m a -> m a
runMerkel config merkel = do
pool <- mkDbPool config
runMerkel' pool config merkel


--------------------------------------------------------------------------------
runMerkelClone :: (MonadIO m) => MerkelClone -> Merkel m a -> m a
runMerkelClone (MerkelClone env) m = do
(x, _, _) <- runRWST (unM m) env ()
return x

+ 19
- 4
lib/Merkel/Types/Password.hs View File

@@ -1,4 +1,10 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE FlexibleInstances #-}

{-

@@ -15,14 +21,13 @@ the LICENSE file.
-}

--------------------------------------------------------------------------------
module Merkel.Types.Password
( Password (..)
) where
module Merkel.Types.Password where

--------------------------------------------------------------------------------
import Data.Aeson (ToJSON, FromJSON)
import Data.Text (Text)
import GHC.Generics
import Merkel.Util.Groundhog

--------------------------------------------------------------------------------
data Password = Password
@@ -30,6 +35,16 @@ data Password = Password
, passwordHashed :: Text -- ^ Hashed password.
} deriving (Generic, Show)

--------------------------------------------------------------------------------
mkPersist merkelCodegenConfig [groundhog|
embedded: Password
fields:
- name: passwordClear
dbName: clear
- name: passwordHashed
dbName: hashed
|]

--------------------------------------------------------------------------------
instance ToJSON Password
instance FromJSON Password

+ 45
- 0
lib/Merkel/Types/Student.hs View File

@@ -0,0 +1,45 @@
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}

{-

This file is part of the package merkel. It is subject to the license
terms in the LICENSE file found in the top-level directory of this
distribution and at:

git://git.devalot.com/merkel.git

No part of this package, including this file, may be copied, modified,
propagated, or distributed except according to the terms contained in
the LICENSE file.

-}

--------------------------------------------------------------------------------
module Merkel.Types.Student where

--------------------------------------------------------------------------------
import Data.Text (Text)
import Merkel.Types.Course
import Merkel.Util.Groundhog

--------------------------------------------------------------------------------
data Student = Student
{ studentName :: Text
, studentCourse :: DefaultKey Course
}

--------------------------------------------------------------------------------
mkPersist merkelCodegenConfig [groundhog|
entity: Student
constructors:
- name: Student
uniques:
- name: unique_name
type: constraint
fields: [ studentName, studentCourse ]
|]

+ 19
- 6
lib/Merkel/Types/VirtualMachine.hs View File

@@ -1,4 +1,10 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE FlexibleInstances #-}

{-

@@ -15,15 +21,16 @@ the LICENSE file.
-}

--------------------------------------------------------------------------------
module Merkel.Types.VirtualMachine
( VirtualMachine (..)
) where
module Merkel.Types.VirtualMachine where

--------------------------------------------------------------------------------
import Data.Aeson (ToJSON, FromJSON)
import Data.Aeson (ToJSON)
import Data.Text (Text)
import GHC.Generics
import Merkel.Types.Course
import Merkel.Types.Password
import Merkel.Types.Student
import Merkel.Util.Groundhog

--------------------------------------------------------------------------------
data VirtualMachine = VirtualMachine
@@ -31,8 +38,14 @@ data VirtualMachine = VirtualMachine
, vmAddress :: Maybe Text -- ^ IP Address if machine has been provisioned.
, vmRootPassword :: Password -- ^ Root password
, vmStudentPassword :: Password -- ^ Student account password
, vmAssignedStudent :: Maybe (DefaultKey Student) -- ^ Maybe assigned to a student
, vmCourse :: DefaultKey Course -- ^ Linked course
} deriving (Generic, Show)

--------------------------------------------------------------------------------
mkPersist merkelCodegenConfig [groundhog|
entity: VirtualMachine
|]

--------------------------------------------------------------------------------
instance ToJSON VirtualMachine
instance FromJSON VirtualMachine

+ 31
- 28
lib/Merkel/Util/Courses.hs View File

@@ -17,41 +17,43 @@ the LICENSE file.
--------------------------------------------------------------------------------
-- | Utilities for working with courses.
module Merkel.Util.Courses
( generateCourse
( createCourse
, findCourseByPassword
) where

--------------------------------------------------------------------------------
import Control.Monad (forM)
import Control.Monad.IO.Class (MonadIO)
import Data.Maybe (listToMaybe)
import Data.Text (Text)
import qualified Data.Text as Text
import Text.Printf (printf)

--------------------------------------------------------------------------------
import Control.Monad.IO.Class (MonadIO)
import Merkel.Types.Course
import Merkel.Types.Password (Password)
import Merkel.Types.Merkel
import Merkel.Types.Password
import Merkel.Types.VirtualMachine
import Merkel.Util.Passwords (generatePassword)
import Merkel.Util.Groundhog
import Merkel.Util.VirtualMachines

--------------------------------------------------------------------------------
-- | Create the virtual machines for a class and then persist all of
-- it to the database.
createCourse :: (MonadIO m)
=> Course
-- ^ The course to save to the database.

-> Int
-- ^ Number of students (virtual machines) to create for
-- this course.

-> Merkel m [VirtualMachine]
createCourse course numVMs = withDB $ do
key <- insert course
vms <- mkVirtualMachines key StartNameAtOne numVMs
mapM_ insert_ vms
return vms

--------------------------------------------------------------------------------
generateCourse :: forall m. (MonadIO m)
=> Text -- ^ The name of the course.
-> Int -- ^ Number of students (virtual machines).
-> m Course
generateCourse name numVMs = do
mainPass <- generatePassword
root <- generatePassword
machines <- vms root
return (Course name mainPass machines)
where
vms :: Password -> m [VirtualMachine]
vms root = forM [1 .. numVMs] $ \n -> do
student <- generatePassword

return VirtualMachine
{ vmName = Text.pack $ printf "vm%02d" n
, vmAddress = Nothing
, vmRootPassword = root
, vmStudentPassword = student
}
findCourseByPassword :: (MonadIO m) => Text -> Merkel m (Maybe (AutoKey Course))
findCourseByPassword p = withDB $ do
keys <- project AutoKeyField $ (CoursePasswordField ~> PasswordClearSelector
==. Text.strip p) `limitTo` 1
return (listToMaybe keys)

+ 67
- 0
lib/Merkel/Util/Groundhog.hs View File

@@ -0,0 +1,67 @@
{-# LANGUAGE FlexibleContexts #-}

{-

This file is part of the package merkel. It is subject to the license
terms in the LICENSE file found in the top-level directory of this
distribution and at:

git://git.devalot.com/merkel.git

No part of this package, including this file, may be copied, modified,
propagated, or distributed except according to the terms contained in
the LICENSE file.

-}

--------------------------------------------------------------------------------
-- | Utilities for working with Groundhog.
module Merkel.Util.Groundhog
( merkelCodegenConfig
, intToKey
, textToKey
, module Database.Groundhog.Postgresql
, module Database.Groundhog.TH
) where

--------------------------------------------------------------------------------
import Data.Int
import Data.Text (Text)
import qualified Data.Text as Text
import qualified Data.Text.Read as Text
import Database.Groundhog.Core
import Database.Groundhog.Generic
import Database.Groundhog.Postgresql
import Database.Groundhog.TH

--------------------------------------------------------------------------------
merkelCodegenConfig :: CodegenConfig
merkelCodegenConfig = defaultCodegenConfig
{ namingStyle = lowerCaseSuffixNamingStyle
}

--------------------------------------------------------------------------------
intToKey :: (PrimitivePersistField (Key a b)) => Int64 -> Key a b
intToKey = mkKey

--------------------------------------------------------------------------------
textToKey :: (PrimitivePersistField (Key a b)) => Text -> Maybe (Key a b)
textToKey t =
case Text.decimal t of
Left _ -> Nothing
Right (n, rest) | Text.null (Text.strip rest) -> Just (intToKey n)
| otherwise -> Nothing

--------------------------------------------------------------------------------
mkKey :: (PrimitivePersistField i, PrimitivePersistField (Key a b))
=> i -> Key a b
mkKey = fromPrimitivePersistValue . toPrimitivePersistValue

--------------------------------------------------------------------------------


-- mkAutoKey :: (Monad m) => Int64 -> m (AutoKey a)
-- mkAutoKey n = liftM fst (pureFromPersistValue $ [PersistInt64 n])

--------------------------------------------------------------------------------
-- mkAutoKey' :: Text -> Maybe (AutoKey a)

+ 1
- 0
lib/Merkel/Util/Passwords.hs View File

@@ -18,6 +18,7 @@ the LICENSE file.
-- External dependencies: @pwgen@, and @mkpasswd@.
module Merkel.Util.Passwords
( generatePassword
, generatePassword'
) where

--------------------------------------------------------------------------------

+ 57
- 0
lib/Merkel/Util/Students.hs View File

@@ -0,0 +1,57 @@
{-# LANGUAGE ScopedTypeVariables #-}

{-

This file is part of the package merkel. It is subject to the license
terms in the LICENSE file found in the top-level directory of this
distribution and at:

git://git.devalot.com/merkel.git

No part of this package, including this file, may be copied, modified,
propagated, or distributed except according to the terms contained in
the LICENSE file.

-}

--------------------------------------------------------------------------------
-- | Utilities for working with students.
module Merkel.Util.Students
( findStudentByIds
, createStudent
) where

--------------------------------------------------------------------------------
import Control.Monad.IO.Class (MonadIO)
import Data.Maybe (listToMaybe)
import qualified Data.Text as Text
import Merkel.Types.Course
import Merkel.Types.Merkel
import Merkel.Types.Student
import Merkel.Util.Groundhog

--------------------------------------------------------------------------------
findStudentByIds :: (MonadIO m)
=> AutoKey Student
-> DefaultKey Course
-> Merkel m (Maybe Student)

findStudentByIds student course = withDB $ do
ss <- select ( AutoKeyField ==. student &&.
StudentCourseField ==. course )

return (listToMaybe ss)

--------------------------------------------------------------------------------
createStudent :: (MonadIO m)
=> Student
-> Merkel m (Maybe (AutoKey Student))

createStudent student' = withDB $ do
let student = student' { studentName = Text.strip (studentName student') }
n <- count ( StudentNameField ==. studentName student &&.
StudentCourseField ==. studentCourse student )

if n > 0
then return Nothing
else Just <$> insert student

+ 140
- 0
lib/Merkel/Util/VirtualMachines.hs View File

@@ -0,0 +1,140 @@
{-# LANGUAGE ScopedTypeVariables #-}

{-

This file is part of the package merkel. It is subject to the license
terms in the LICENSE file found in the top-level directory of this
distribution and at:

git://git.devalot.com/merkel.git

No part of this package, including this file, may be copied, modified,
propagated, or distributed except according to the terms contained in
the LICENSE file.

-}

--------------------------------------------------------------------------------
module Merkel.Util.VirtualMachines
( FirstNameIndex (..)
, SetAddress (..)
, mkVirtualMachines
, setAddresses
, assignToStudent
, findVmByStudent
) where

--------------------------------------------------------------------------------
import Control.Monad (forM_, liftM)
import Control.Monad.IO.Class (MonadIO)
import Data.Maybe (listToMaybe)
import Data.Text (Text)
import qualified Data.Text as Text
import Database.Groundhog.Core (PrimitivePersistField(..), PersistEntity(..))
import Database.Groundhog.Generic (firstRow, pureFromPersistValue)
import Text.Printf (printf)

--------------------------------------------------------------------------------
import Merkel.Types.Course
import Merkel.Types.Merkel
import Merkel.Types.Student
import Merkel.Types.VirtualMachine
import Merkel.Util.Groundhog
import Merkel.Util.Passwords

--------------------------------------------------------------------------------
data FirstNameIndex = StartNameAtOne | StartNameAt Int

--------------------------------------------------------------------------------
data SetAddress = SetAddress Text Text

--------------------------------------------------------------------------------
-- | Translate 'FirstNameIndex' to an @Int@.
firstNameIndex :: FirstNameIndex -> Int
firstNameIndex StartNameAtOne = 1
firstNameIndex (StartNameAt n) = n

--------------------------------------------------------------------------------
-- | Build fresh 'VirtualMachine' values, but don't persist them to
-- the database.
mkVirtualMachines :: forall m. (MonadIO m)
=> DefaultKey Course
-- ^ The course to associate with.

-> FirstNameIndex
-- ^ The index of the first machine name.

-> Int
-- ^ Total number of machines to create.

-> m [VirtualMachine]
-- ^ The created machines.

mkVirtualMachines course start total =
mapM mkVM [firstNameIndex start .. total]

where
mkVM :: (MonadIO m ) => Int -> m VirtualMachine
mkVM n = do
root <- generatePassword
student <- generatePassword

return VirtualMachine
{ vmName = Text.pack $ printf "vm%02d" n
, vmAddress = Nothing
, vmRootPassword = root
, vmStudentPassword = student
, vmAssignedStudent = Nothing
, vmCourse = course
}

--------------------------------------------------------------------------------
-- | Update the IP address for the listed virtual machines.
setAddresses :: (MonadIO m)
=> DefaultKey Course
-> [SetAddress]
-> Merkel m ()
setAddresses course as = withDB_ $ forM_ as $ \(SetAddress name ip) ->
update [ VmAddressField =. Just ip ] -- SET
( VmCourseField ==. course &&. -- WHERE
VmNameField ==. name )


--------------------------------------------------------------------------------
-- | Attempt to assign a 'VirtualMachine' to a 'Student'.
assignToStudent :: (MonadIO m)
=> DefaultKey Course
-> DefaultKey Student
-> Merkel m (Maybe VirtualMachine)

assignToStudent course student = withDB $ do
-- Need to do this by hand due to FOR UPDATE
row <- queryRaw False sql
[ toPrimitivePersistValue course] >>= firstRow

case row of
Nothing -> return Nothing
Just xs -> do
rowid <- liftM fst (pureFromPersistValue xs)

update [ VmAssignedStudentField =. Just student ]
( AutoKeyField ==. (rowid :: AutoKey VirtualMachine) )


vms <- select ( VmAssignedStudentField ==. Just student &&.
VmCourseField ==. course )

return (listToMaybe vms)
where
sql :: String
sql = mconcat [ "SELECT id FROM virtual_machine "
, "WHERE vm_course = ? "
, "AND vm_assigned_student IS NULL AND vm_address IS NOT NULL "
, "LIMIT 1 ORDER BY vm_name FOR UPDATE"
]

--------------------------------------------------------------------------------
findVmByStudent :: (MonadIO m) => DefaultKey Course -> DefaultKey Student -> Merkel m (Maybe VirtualMachine)
findVmByStudent course student = withDB $ do
vms <- select $ ( VmCourseField ==. course &&. VmAssignedStudentField ==. Just student) `limitTo` 1
return (listToMaybe vms)

+ 31
- 11
merkel.cabal View File

@@ -22,11 +22,19 @@ flag maintainer
library
exposed-modules:
Merkel
Merkel.Operations.Generate
Merkel.Operations.Create
Merkel.Operations.Migrate
Merkel.Operations.Snap.JoinCourse
Merkel.Types.Config
Merkel.Types.Course
Merkel.Types.Merkel
Merkel.Types.Password
Merkel.Types.Student
Merkel.Types.VirtualMachine
Merkel.Util.VirtualMachines
Merkel.Util.Courses
Merkel.Util.Groundhog
Merkel.Util.Students
Merkel.Util.Passwords
Merkel.Util.Templates
@@ -38,21 +46,33 @@ library
if flag(maintainer)
ghc-options: -Werror

build-depends: base >= 4.9 && < 5
, aeson >= 1.0 && < 1.3
, bytestring >= 0.10 && < 0.11
, containers >= 0.5 && < 0.6
, filepath >= 1.4 && < 1.5
, mustache >= 2.1 && < 2.3
, process >= 1.4 && < 1.7
, text >= 1.2 && < 1.3
build-depends: base >= 4.9 && < 5
, aeson >= 1.0 && < 1.3
, bytestring >= 0.10 && < 0.11
, containers >= 0.5 && < 0.6
, filepath >= 1.4 && < 1.5
, groundhog >= 0.8 && < 0.9
, groundhog-postgresql >= 0.8 && < 0.9
, groundhog-th >= 0.8 && < 0.9
, lens >= 4.15 && < 5.0
, mtl >= 2.2 && < 2.3
, mustache >= 2.1 && < 2.3
, process >= 1.4 && < 1.7
, resource-pool >= 0.2 && < 0.3
, snap >= 1.0 && < 1.1
, snap-core >= 1.0 && < 1.1
, text >= 1.2 && < 1.3
, transformers >= 0.5 && < 1.0

--------------------------------------------------------------------------------
executable merkel
main-is: src/merkel.hs
hs-source-dirs: src
main-is: Main.hs
default-language: Haskell2010
ghc-options: -Wall -fwarn-incomplete-uni-patterns
build-depends: base, aeson, bytestring, merkel, text
build-depends: base, aeson, bytestring, lens, merkel, snap, text
, optparse-applicative >= 0.13 && < 0.15
, snap-server >= 1.0 && < 1.1

if flag(maintainer)
ghc-options: -Werror

+ 22
- 0
merkel.nix View File

@@ -0,0 +1,22 @@
{ mkDerivation, aeson, base, bytestring, containers, filepath
, groundhog, groundhog-postgresql, groundhog-th, lens, mtl
, mustache, optparse-applicative, process, resource-pool, snap
, snap-core, snap-server, stdenv, text, transformers
}:
mkDerivation {
pname = "merkel";
version = "0.1.0.0";
src = ./.;
isLibrary = true;
isExecutable = true;
libraryHaskellDepends = [
aeson base bytestring containers filepath groundhog
groundhog-postgresql groundhog-th lens mtl mustache process
resource-pool snap snap-core text transformers
];
executableHaskellDepends = [
aeson base bytestring lens optparse-applicative snap snap-server
text
];
license = stdenv.lib.licenses.bsd3;
}

+ 5
- 2
services/default.nix View File

@@ -12,11 +12,14 @@

# Basic configuration:
config = {
system.stateVersion = "17.09";

networking.domain = "devalot.com";
networking.firewall.allowPing = false;
networking.firewall.allowPing = true;
networking.firewall.enable = true;
networking.useDHCP = true;
networking.firewall.pingLimit = "--limit 1/minute --limit-burst 5";
networking.nameservers = [ "8.8.8.8" "8.8.4.4" ];
networking.useDHCP = true;

programs.ssh.startAgent = false;


+ 8
- 1
services/vnc.nix View File

@@ -26,6 +26,7 @@ in with lib;

systemd.services.vnc = {
description = "VNC server for X11";
path = with pkgs; [ openssl ];

wantedBy = [ "default.target" ];
after = [ "network.target" "display-manager.service" "${cfg.passwordKey}-key.service" ];
@@ -38,13 +39,19 @@ in with lib;
'';

script = ''
${pkgs.x11vnc}/bin/x11vnc -display :0 -ncache 10 -loop -v -passwdfile read:/run/${cfg.passwordKey}
${pkgs.x11vnc}/bin/x11vnc -display :0 \
-ncache 10 -rfbport ${toString portNum} \
-shared -loop -v \
-passwdfile read:/run/${cfg.passwordKey}
'';

serviceConfig = {
User = student.userName;
Type = "simple";
PermissionsStartOnly = true;
Restart = "always";
RestartSec = 3;
StartLimitIntervalSec = 0;
LimitRTPRIO = 50;
LimitRTTIME = "infinity";
ProtectSystem = true;

+ 89
- 0
src/Create.hs View File

@@ -0,0 +1,89 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}

{-

This file is part of the package merkel. It is subject to the license
terms in the LICENSE file found in the top-level directory of this
distribution and at:

git://git.devalot.com/merkel.git

No part of this package, including this file, may be copied, modified,
propagated, or distributed except according to the terms contained in
the LICENSE file.

-}

--------------------------------------------------------------------------------
module Create
( Options
, optionsParser
, run
) where

--------------------------------------------------------------------------------
import Control.Monad.IO.Class (MonadIO, liftIO)
import Data.Monoid
import Data.Text (Text)
import Merkel.Operations.Create
import Merkel.Types.Merkel
import Options.Applicative
import System.Exit (exitFailure)
import System.IO

--------------------------------------------------------------------------------
data Options = Options
{ optionsName :: Text
, optionsNix :: FilePath
, optionsTemplate :: FilePath
, optionsStudents :: Int
}

--------------------------------------------------------------------------------
optionsParser :: Parser Options
optionsParser =
Options <$> option auto ( long "name" <>
short 'n' <>
metavar "NAME" <>
help "The name of the course to create" )

<*> option str ( long "definition" <>
short 'd' <>
metavar "FILE" <>
help "The Nix file that defines this course" )

<*> option str ( long "template" <>
short 't' <>
metavar "FILE" <>
help "The Nix template file to use" )

<*> option auto ( long "students" <>
short 's' <>
metavar "NUM" <>
showDefault <>
value 1 <>
help "The number of expected students" )

--------------------------------------------------------------------------------
run :: (MonadIO m) => Options -> Merkel m ()
run Options{..} = do
course <- create details

case course of
Left e -> liftIO (die e)
Right c -> liftIO (print c)

where
details :: Details
details = Details { detailsCourseName = optionsName
, detailsCourseNixFile = optionsNix
, detailsTemplateFile = optionsTemplate
, detailsOutputDir = "instances"
, detailsNumStudents = optionsStudents
}

die :: String -> IO ()
die e = do
hPutStrLn stderr ("ERROR: " ++ e)
exitFailure

+ 74
- 0
src/Main.hs View File

@@ -0,0 +1,74 @@
{-# LANGUAGE OverloadedStrings #-}

{-

This file is part of the package merkel. It is subject to the license
terms in the LICENSE file found in the top-level directory of this
distribution and at:

git://git.devalot.com/merkel.git

No part of this package, including this file, may be copied, modified,
propagated, or distributed except according to the terms contained in
the LICENSE file.

-}

--------------------------------------------------------------------------------
module Main (main) where

--------------------------------------------------------------------------------
import Options.Applicative

--------------------------------------------------------------------------------
import qualified Server
import qualified Create

--------------------------------------------------------------------------------
import Merkel.Operations.Migrate
import Merkel.Types.Config
import Merkel.Types.Merkel

--------------------------------------------------------------------------------
data Command = CmdCreate Create.Options
| CmdServer Server.Options

--------------------------------------------------------------------------------
optionsParser :: Parser Command
optionsParser = commands
where
commands =
subparser $ mconcat [createCmd, serverCmd]

createCmd =
command "create"
(info (CmdCreate <$> Create.optionsParser) (progDesc createDesc))

createDesc =
"Create a new course"

serverCmd =
command "server"
(info (CmdServer <$> Server.optionsParser) (progDesc serverDesc))

serverDesc =
"Start the HTTP server"

--------------------------------------------------------------------------------
main :: IO ()
main = do
options <- execParser $ info (optionsParser <**> helper) idm

let run = case options of
CmdCreate o -> Create.run o
CmdServer o -> Server.run o

runMerkel config $ do
migrateSchema
run

where
config :: Config
config = Config { configConnectString = "user=merkel dbname=merkel password=merkel"
, configPoolSize = 1
}

+ 84
- 0
src/Server.hs View File

@@ -0,0 +1,84 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}

{-

This file is part of the package merkel. It is subject to the license
terms in the LICENSE file found in the top-level directory of this
distribution and at:

git://git.devalot.com/merkel.git

No part of this package, including this file, may be copied, modified,
propagated, or distributed except according to the terms contained in
the LICENSE file.

-}

--------------------------------------------------------------------------------
module Server
( Options
, optionsParser
, run
) where

--------------------------------------------------------------------------------
import Control.Lens
import Control.Monad.IO.Class (MonadIO, liftIO)
import Data.ByteString (ByteString)
import qualified Data.ByteString as ByteString
import Data.Monoid
import Options.Applicative
import Snap
import Snap.Http.Server.Config (Config)
import qualified Snap.Http.Server.Config as Config
import Snap.Snaplet.Session (SessionManager)
import Snap.Snaplet.Session.Backends.CookieSession (initCookieSessionManager)

--------------------------------------------------------------------------------
import Merkel.Operations.Snap.JoinCourse
import Merkel.Types.Merkel

--------------------------------------------------------------------------------
data Options = Options

--------------------------------------------------------------------------------
data App = App
{ _cookies :: Snaplet SessionManager
, _joinCourse :: Snaplet JoinCourse
}

makeLenses ''App

--------------------------------------------------------------------------------
optionsParser :: Parser Options
optionsParser = pure Options

--------------------------------------------------------------------------------
config :: MonadSnap m => Config m a
config = Config.setVerbose False $
Config.setErrorLog (Config.ConfigIoLog stdoutLog) $
Config.setAccessLog (Config.ConfigIoLog stdoutLog) $
Config.setPort 8000 $
Config.setBind "0.0.0.0"
Config.defaultConfig
where
stdoutLog :: ByteString -> IO ()
stdoutLog = ByteString.putStr . (<> "\n")

--------------------------------------------------------------------------------
-- | Application initializer.
appInit :: MerkelClone -> SnapletInit App App
appInit mc = makeSnaplet "app" "Merkel" Nothing $ do
sm <- nestSnaplet "sess" cookies cookieInit
jc <- nestSnaplet "json" joinCourse (joinCourseInit mc sm)
return (App sm jc)

where
cookieInit = initCookieSessionManager "path" "s" Nothing Nothing

--------------------------------------------------------------------------------
run :: (MonadIO m) => Options -> Merkel m ()
run _ = do
mc <- cloneMerkel
liftIO (serveSnaplet config $ appInit mc)

+ 0
- 46
src/merkel.hs View File

@@ -1,46 +0,0 @@
{-# LANGUAGE OverloadedStrings #-}

{-

This file is part of the package merkel. It is subject to the license
terms in the LICENSE file found in the top-level directory of this
distribution and at:

git://git.devalot.com/merkel.git

No part of this package, including this file, may be copied, modified,
propagated, or distributed except according to the terms contained in
the LICENSE file.

-}

--------------------------------------------------------------------------------
module Main (main) where

--------------------------------------------------------------------------------
import Merkel.Operations.Generate
import System.Exit (exitFailure)
import System.IO

--------------------------------------------------------------------------------
main :: IO ()
main = do
course <- makeCourseFiles config

case course of
Left e -> die e
Right _ -> return ()

where
config :: Config
config = Config { configCourseName = "2017-10-03-M-DV"
, configCourseNixFile = "secure-coding.nix"
, configTemplateFile = "templates/libvirt.nix"
, configOutputDir = "instances"
, configNumStudents = 1
}

die :: String -> IO ()
die e = do
hPutStrLn stderr ("ERROR: " ++ e)
exitFailure

+ 1
- 1
templates/ec2.nix View File

@@ -18,7 +18,7 @@ let
inherit region accessKeyId;
instanceType = "t2.small";
keyPair = resources.ec2KeyPairs.auto;
ebsInitialRootDiskSize = 5;
ebsInitialRootDiskSize = 6;
};
};
in pkgs.lib.recursiveUpdate

+ 5
- 1
templates/libvirt.nix View File

@@ -12,7 +12,11 @@ let
deployment.targetEnv = "libvirtd";
deployment.libvirtd.vcpu = 1;
deployment.libvirtd.memorySize = 2048;
deployment.libvirtd.headless = false;
deployment.libvirtd.headless = true;

deployment.libvirtd.extraDevicesXML = ''
<graphics type='vnc' port='-1' autoport='yes'/>
'';
};
in pkgs.lib.recursiveUpdate
{

+ 1
- 1
utils/mkvms.nix View File

@@ -28,6 +28,6 @@ let

src = lib.importJSON jsonFile;
vms = lib.fold (a: b: {"${a.name}" = a.exprn;} // b)
{} (map mkVM src.courseVMs);
{} (map mkVM src);

in vms

Loading…
Cancel
Save